TeX 1995 July/TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO/web/fweb/fweb-1.40/web/ftangle.web

Text File | 1993-10-29 | 187KB | 7,953 lines

@z --- ftangle.web ---

FWEB version 1.40 (October 30, 1993)

Based on version 0.5 of S. Levy's CWEB [copyright (C) 1987 Princeton University]

@x-----------------------------------------------------------------------------


\Title{FTANGLE.WEB} % The FTANGLE processor.

@c

@* INTRODUCTION.  \FTANGLE\ has a fairly straightforward outline.  It
operates in two phases: first it reads the source file, saving the code in
compressed form; then outputs the code, after shuffling it around.  It can
be compiled with the optional flag |DEBUG|. (See \.{typedefs.hweb}.)

@m _FTANGLE_ // Identifies this module to the \.{*.hweb} header files.
@d _FTANGLE_h
@d _FWEB_h

@A
@<Possibly split into parts@>@;

@<Include files@>@;
@<Typedef declarations@>@;
@<Prototypes@>@;
@<Global variables@>@;

/* For pc's, the file is split into three compilable parts using the
compiler-line macro |part|, which must equal either~1, 2, or~3. */
#if(part == 0 || part == 1)
    @<Part 1@>@;
#endif // |Part == 1|

#if(part == 0 || part == 2)
    @<Part 2@>@;
#endif // |part == 2|

#if(part == 0 || part == 3)
    @<Part 3@>@;
#endif // |part == 3|

@ Here is the main program.  See the user's manual for a detailed
description of the command line.
@<Part 1@>=@[

int main FCN((ac, av))
    int ac C0("Number of arguments.")@;
    outer_char **av C1("Argument list.")@;
{
ini_timer(); /* Timing statistics are printed at the end of the run; see
            \.{common.web}. */

/* Remember the arguments to |main| in global variables. */
  argc = ac; @+ argv = av;

  ini_program(tangle); // Set the |program| flag etc.; see \.{common.web}.

@<Initialize everything@>;

  phase1(); // Read all the user's text and compress it into |tok_mem|.
  phase2(); // Output the contents of the compressed tables.

  if(statistics) see_tstatistics(); // Optional statistical info.

return wrap_up(); // We actually |exit| from here.
}

@ Here are the initializations done before the beginning of phase~1.
@<Initialize everything@>=
{
@<Allocate initial tables@>@; // Stuff that must be used for command line.
common_init(); // Expand the command line here.
@<Allocate dynamic memory@>@; // Local dynamic memory.
@<Set initial values@>@;
ini_internal_fcns(); // Internal built-in function macros.
ini_Ratfor(); // Initialize \Ratfor.
}

@I typedefs.hweb // Declarations common to both \FTANGLE\ and \FWEAVE.

@I val.hweb // Stuff for expression evaluation.

@I macs.hweb // Macros for macro processing.


@ The function prototypes must appear before the global variables.
@<Proto...@>=

#include "t_type.h" // Function prototypes for \FTANGLE.

@* CODE for OUTPUT. When |language != C|, we must remember the last fragment
of code in order to implement |+=| and similar operators for \Fortran\ or
\Ratfor.

@d RST_LAST_EXPR {plast_char = last_char; last_xpr_overflowed = NO;}

@d INDENT_SIZE 2 /* Number of columns to indent for each level of
beautified Ratfor output. (Put into style file?) */

@<Glob...@>=

EXTERN int indnt_size SET(INDENT_SIZE);
    // So we can interface to \.{rat77.web}.

EXTERN outer_char HUGE *last_char, HUGE *last_end; // Dynamic array.
EXTERN outer_char HUGE *plast_char; // Current position in |last_char|.
EXTERN BUF_SIZE max_expr_chars; // Allocated length of |last_char|.

EXTERN boolean last_xpr_overflowed SET(NO);

EXTERN int indent_level SET(0); // Current state of Ratfor output.

@ Allocate the |last_char| array.
@<Allocate dynamic memory@>=

ALLOC(outer_char,last_char,ABBREV(max_expr_chars),max_expr_chars,0);
last_end = last_char + max_expr_chars;
plast_char = last_char;

@ An interface to \.{rat77.web}
@<Part 1@>=@[

SRTN rst_last(VOID)@/
RST_LAST_EXPR@;

@ For speed, we'll buffer up the C~output.  Characters are put temporarily
into |C_buffer|.  That buffer is flushed whenever a newline is emitted.  If
the buffer ever gets full, an attempt is made to split the buffer at a
reasonable place.  To accomplish that, we have the array |str_start| of
pointers to positions in |C_buffer|.  The odd elements in |str_start| are
the positions at which |stringg| mode starts; the even elements are the
positions after |stringg| mode ends.  The zeroth element is |C_buffer|
itself, and the last position, which should always be odd, is |pC_buffer|,
the current position in the buffer.  Thus, if there are no strings in the
buffer, we have |str_start[0] == C_buffer|, |str_start[1] == pC_buffer|.
The ranges allowed to be split are $[0,1)$, $[2,3)$, etc.

@<Glob...@>=

/* --- Output buffer for C --- */
EXTERN outer_char HUGE *C_buffer, HUGE *pC_end; // Dynamically allocated.
EXTERN outer_char HUGE *pC_buffer; // Current position.
EXTERN BUF_SIZE C_buf_size; // Length of dynamic buffer array.

/* --- String positions in that buffer --- */
EXTERN outer_char HUGE *split_pos; // Current position.

/* --- Output buffer for \TeX\ --- */
EXTERN outer_char HUGE *X_buffer, HUGE *pX_end; // Dynamically allocated.
EXTERN outer_char HUGE *pX_buffer; // Current position.
EXTERN BUF_SIZE X_buf_size; // Length of dynamic buffer array.

@
@<Allocate dyn...@>=

/* --- Allocate C output buffer --- */
ALLOC(outer_char,C_buffer,ABBREV(C_buf_size),C_buf_size,0);
pC_end = C_buffer + C_buf_size - 1; // Allow for extra backslash if necessary.
pC_buffer = C_buffer; // Initialize to beginning.

#if FANCY_SPLIT
    @<Reset split position@>@;
#endif /* |FANCY_SPLIT| */

/* --- Allocate \TeX\ output buffer --- */
ALLOC(outer_char,X_buffer,ABBREV(X_buf_size),X_buf_size,0);
pX_end = X_buffer + X_buf_size;
pX_buffer = X_buffer; // Initialize to beginning.

@ The |split_C| routine is called whenever |C_buffer| fills.  If the flag
|FANCY_SPLIT| is off (the ANSI case), we just continue everything with a
backslash.  Otherwise, we do a fancy break, described below.
@<Part 1@>=@[

SRTN split_C(VOID)
{
#if FANCY_SPLIT
    @<Fancy split@>@;
#else
    @<Emit a backslash and newline@>@;
#endif /* |FANCY_SPLIT| */
}

@ For the fancy split, we do the following: If we are in a string at this
moment, we emit a backslash and dump the whole buffer.  Otherwise, we hunt
through the |str_start| array for allowable positions to break.

@<Fancy split@>=
@{
/* Split strings, but not constants. */
if(in_string && split_pos == C_buffer)
    {
    @<Emit a backslash and newline@>@;
    return;
    }

*pC_buffer = '\0';
split0_C(split_pos);
}

@ When we buffer stuff out in any way, e.g. with |C_out|, we must reset the
split position.

@<Reset split position@>=
{
split_pos = C_buffer;
}

@ Here is the bare-bones C~continuation.

@d NO_INDENT 0
@d INDENT 2

@<Emit a backsl...@>=
{
if(!meta_mode)
    *pC_buffer++ = '\\'; // There's always room for one more character.

C_out(C_buffer,pC_buffer,&pC_buffer,OC("\n"),'\0',NO_INDENT);
    // Dump out all the way to the end.
}

@ Here, given an allowable range we search for a split position.
@<Part 1@>=

#if FANCY_SPLIT
@[
SRTN split0_C FCN((p))
    outer_char *p C1("Position for the split")@;
{
int indent;

/* If no break has been found, force a break at the end. */
if(p==C_buffer)
    {
    *pC_buffer++ = '\\';
    p = pC_buffer;
    indent = NO_INDENT;
    }
else indent = INDENT;

C_out(C_buffer,p,&pC_buffer,OC("\n"),'\0',indent);
    // Output from |C_buffer| to~|p|.

@#if 0
    UPDATE_TERMINAL;
    printf("\nOutput line %u split\n",OUTPUT_LINE);
@#endif
}
#endif // |FANCY_SPLIT|

@ Write out (part of) the |C_buffer|.
@<Part 1@>=@[

SRTN C_out FCN((C_buffer,p,ppC_buffer,end_str,begin_char,indent))
    outer_char HUGE *C_buffer C0("Buffer we're working with")@;
    outer_char HUGE *p C0("End (next available pos)")@;
    outer_char HUGE * HUGE *ppC_buffer C0("")@;
    outer_char *end_str C0("")@;
    outer_char begin_char C0("")@;
    int indent C1("Should the next buffer be indented?")@;
{
int n = *ppC_buffer - p; /* How many left in buffer. */

if(p > C_buffer)
    WRITE1(C_buffer,p-C_buffer)@;

/* Add trailing characters if necessary. */
if(*end_str) WRITE1(end_str,STRLEN(end_str))@;

/* Reset the pointer, then insert the beginning character if necessary. */
*ppC_buffer = C_buffer;
if(begin_char) *(*ppC_buffer)++ = begin_char;

/* Add optional indentation (i.e., fill with blanks). */
while(indent--)
    *(*ppC_buffer)++ = ' ';

/* If there's still stuff in the buffer, move it to the beginning. */
if(n)
    {
    STRNCPY(*ppC_buffer,p,n);
    *ppC_buffer += n; // Reset the current pointer if necessary.
    }

flush0(); // Count the lines.
@<Reset split...@>@;
}

@ Here are output macros and routines for \FTANGLE.

@d OUT_FILE outp_file[lan_num(out_language)] // Output of \FTANGLE.

/* The next may not be used. */
@d C_printf(c,a)
    {
    if(!out_file) open_out(OC(""),YES);
    if(fprintf(out_file,c,a)<0) out_error(OC("fprintf"));
    }

@<Part 1@>=@[

SRTN C_putc FCN((c))
    outer_char c C1("Character to be sent to output.")@;
{
CHECK_OPEN; // Output files are opened only when necessary.

/* Remember the output character, since we may want to spit it out again
later, as in |i *= expr| $\to$ |i = i*(expr)|. Turning off the
|compound_assignments| flag by option \.{-+} will speed things up a bit. */
if(compound_assignments && FORTRAN_LIKE(language))
    if(plast_char >= last_end) last_xpr_overflowed = YES;
    else *plast_char++ = c;

if(dbg_output) printf("c = '%c' (0x%x)\n",c,c);

if(at_beginning && meta_mode && !nuweb_mode && in_string)
    { /* Invoke |C_putc| recursively. */
    at_beginning = NO; // Prevent infinite recursion.
    out_pos = 0; // For \Fortran.
    pmeta = &t_style.meta[lan_num(language)];
    OUT_STR(in_version ? pmeta->hdr.prefx : pmeta->msg.prefx);
    }

switch(language)
    {
 case RATFOR:
 case RATFOR_90:
    if(!Ratfor77)
        {
        RAT_out(c); /* Old-style \Ratfor. Modern
\Ratfor\ falls through to \Fortran. */
        break;
        }

 case FORTRAN:
 case FORTRAN_90:
    if(reverse_indices && !in_string)
        @<Reverse \Fortran\ indices@>@;
    else
        buffer_out(c);

    break;

 case LITERAL:
 case TEX:
    @<Buffer \TeX\ output@>@;
    break;

 case C:
 case C_PLUS_PLUS:
 default:
#ifndef mac // \.{Machine-dependent}: Don't buffer C output.
    @<Buffer C output@>@;
/* If the above buffering (a relatively recent addition) doesn't work, use
the following: */
#else
    if(c == '\n') flush0(); // Count the lines.
    PUTC(c);
#endif /* |mac| */
    break;
    }

at_beginning = BOOLEAN(c=='\n');
}

@ A recent addition to speed up the C~output.
@<Buffer C output@>=
@{
*pC_buffer++ = c; // Add present character to buffer.

if(c == '\n')
    C_out(C_buffer,pC_buffer,&pC_buffer,OC(""),'\0',NO_INDENT);
    // Output whole buffer.
else if(pC_buffer == pC_end)
    split_C();
}

@
@<Buffer \TeX...@>=
{
*pX_buffer++ = c; /* Add present character to buffer. */

if(c == '\n')
    C_out(X_buffer,pX_buffer,&pX_buffer,OC(""),
     (outer_char)CHOICE(meta_mode && language==TEX, '%', '\0'),NO_INDENT);
else if(pX_buffer == pX_end)
    split_X();
}

@
@<Part 1@>=@[

SRTN split_X(VOID)
{
outer_char HUGE *p = pX_buffer;

WHILE()
    {
    if(p==X_buffer) @<Print warning message about unsplittable \TeX\
line, break the line, and |return|@>@;

    if(*p == ' ')
        {
        C_out(X_buffer,p+1,&pX_buffer,OC("\n"),
         (outer_char)CHOICE(meta_mode && language==TEX, '%', '\0'),
         NO_INDENT);
        return;
        }

    if(*(p--) == '\\' && *p != '\\')
        {
        C_out(X_buffer,p+1,&pX_buffer,
         language==TEX ? OC("%\n") : OC("\n"),
         (outer_char)CHOICE(meta_mode && language==TEX, '%', '\0'),
         NO_INDENT);
        return;
        }
    }
}

@
@<Print warning message about unsplit...@>=
{
ERR_PRINT(T,"Line had to be broken");
C_out(X_buffer,pX_buffer,&pX_buffer,
    language==TEX ? OC("%\n") : OC("\n"),
    '\0',NO_INDENT);
return;
}

@ For~C, output of characters is very simple: use of |putc| suffices. For
\Ratfor\ it's just slightly more complicated; we have to intercept the
meta-comment characters. (We don't need to use metacomments in~C, since
C~has its own preprocessor.) \Fortran\ is much more involved; we must
buffer things up, then flush them out line by line in order to respect the
72~column restriction and emit continuation characters appropriately.

@d NOT_CONTINUATION 0
@d CONTINUATION 1

@<Part 1@>=@[

static outer_char last_out = '\0'; // In \Fortran, the last character output.

/* Various flags help \Fortran\ out. */
static boolean is_label = NO;
static boolean should_continue = NO;
static continuation_line = NOT_CONTINUATION;

static STMT_LBL stmt_num[50]; /* Archaic; for numbering
            |do|s in \Fortran. Should use \Ratfor\ instead. */
static short do_level = 0;

@ The following variables are needed in both parts~1 and~2.
@<Glob...@>=

EXTERN int rst_pos SET(0); // The position immediately after resetting.
EXTERN int out_pos SET(0); // Current position in \Fortran's output buffer.
EXTERN boolean in_string SET(NO); // Faster version of the output state.
EXTERN boolean in_constant SET(NO); // Ditto.
EXTERN boolean started_vcmnt SET(NO);
EXTERN boolean meta_mode SET(NO);

@ The function |C_putc| is used for all languages in order to send the
character to the right place. Here is a routine which formats and prints
out a string. It's used in printing out the line information.  Note use of
the macro |vsprintf_| to take account of the different way that Sun-CC
handles variable arguments.

@d N_STRBUF 150

@<Part 1@>=@[

SRTN C_sprintf FCN(VA_ALIST((fmt,n VA_ARGS)))
    VA_DCL(
    CONST outer_char fmt[] C0("String to be printed.")@;
    int n C2("Number of arguments to follow."))@;
{
VA_LIST(arg_ptr)@;
outer_char temp[N_STRBUF];
outer_char HUGE *t;

VA_START(arg_ptr,n);
vsprintf_((char *)temp,(CONST char *)fmt,arg_ptr)@;  // Length not checked now.
va_end(arg_ptr);

for(t=temp; *t; ++t) C_putc(*t);
}

@ Here is \Ratfor's output routine. All it does is intercept the
meta-comment characters and makes the intervening text into a comment.

@d send_new_line RST_LAST_EXPR@; flush0(); PUTC('\n')

@<Part 1@>=@[

SRTN RAT_out FCN((c))
    outer_char c C1("Output this character to \Ratfor.")@;
{
switch(c)
    {
    case end_meta:
        send_new_line;
        return;

    case begin_meta:
        if(meta_mode) return; // The second in a row.
        meta_mode = YES; // NOTE: FALLS THROUGH to next case.

    case '\n':
        send_new_line;
        if(meta_mode) PUTC('#'); // \Ratfor\ comment.
        return;

    default:
        PUTC(c);
        return;
    }
}

@ \Fortran's output routine is much more complicated, because things have
to be buffered up.

@<Glob...@>=

IN_COMMON outer_char outp_buf[];    // \Fortran's output buffer.
IN_COMMON int nbuf_length; // Maximum of above, for breaking.
EXTERN boolean out_at_beginning SET(YES); // Flag for the output buffer.

@ Send a character to \Fortran's output (buffered).  Possibly against the
general philosophy of \WEB, here we make some attempt to make the output
readable by indenting loop structures.  (It's not clear the indentation
scheme has been adequately tested when the level is very deep.)

@<Part 1@>=@[

SRTN buffer_out FCN((c))
    outer_char c C1("Output this character to the \Fortran\ buffer.")@;
{
outer_char *px; // For |in_string| |meta_mode| processing.

@<|switch| for single character output to \Fortran@>@;

/* When a statement label ends, skip to column~7. */
if(is_label && !isdigit(c) )
    {
    is_label = NO;
    out_pos = 6 + indent_level*INDENT_SIZE;
    if(c==':' || c==' ') return; // Throw away the trailing colon.
    }

@<Possibly number |do|s@>@;

/* Can't put it off any longer: Put the character into the buffer. */
last_out = outp_buf[out_pos++] = c;

return;
}

@ Not every character fired at |buffer_out| should actually be printed on
the output file; some are special flags.

@<|switch| for single char...@>=

switch(c)
    {
case '\0': if(!in_string) return;  // In case a null sneaks in, ignore it.

/* Reset the verbatim comment mode. We have to remember whether we were in
the middle of a line; if we were, we must resume continuation mode. */
    if(in_string && started_vcmnt)
        {
        NEWLINE_TO_FORTRAN(should_continue);
        started_vcmnt = NO;
        return;
        }
    break;

case '{':
case '}':
/* Filter out braces from \Ratfor. */
    if(!in_string && xpn_Ratfor) return;
    break;

 /* Ignore any blanks at beginning of line. */
case ' ':
    if(out_at_beginning) return;
    break;

@t\4@>@<Case for newline@>@;

/* Semicolons not in strings mean emit a new line (except when they were
earlier translated into |semi| during stringizing). */
case ';':
  if(!(in_string || in_constant))
    {
    NEWLINE_TO_FORTRAN(NOT_CONTINUATION);
    return;
    }
   break;

case interior_semi:
case semi:
    c = ';'; @+ break;

 /* Handle meta-comments. */
case begin_meta:
    if(!meta_mode && last_out != '\n') flush_out(YES);
    meta_mode = YES;
    if(in_string)
        { /* Start standard meta-comment. */
        TO_BUFFER(top);
        if(out_pos > 0) flush_out(YES);
        }
    rst_out(NOT_CONTINUATION);
    return;

case end_meta:
    if(in_string)
        { /* Finish standard meta-comment. */
        TO_BUFFER(bottom);
        if(out_pos > 0) flush_out(YES);
        started_vcmnt = NO;
        }
    else flush_out(YES);

    rst_out(NOT_CONTINUATION);
    return;
   }

/* If we're still going at column 73, emit a new line and make the next
line a continuation line. */
if(out_pos >= nbuf_length)
    {
    if(free_Fortran) outp_buf[out_pos++] = '&'; // Standard F--90 contin.
    flush_out(YES);
    rst_out(CONTINUATION);    /* Continuation. */

    if(in_string && started_vcmnt) @<Begin verbatim comment line@>;
    }

if(out_at_beginning)
    {
    out_at_beginning = NO;

/* Statement labels require special treatment. When we sense one, we raise
a special flag and put them into column~1. */
    if(!in_string)
           if(isdigit(c) && !is_label)
        {
        is_label = YES;
        out_pos = 0;
        }
       else if(c=='#')
        { /* Place the \&{\#line} command in column~1. */
        outp_buf[0] = (outer_char)CHOICE(free_90,
            begin_comment_char[lan_num(out_language)], '*');
// Treat as comment.
        out_pos = 1;
        return;
        }
    }

@ Processing a newline is somewhat annoying because of the need to handle
verbatim comments. The logic could be cleaned up here, but since it
permeates the entire code, don't try it.

@<Case for newline@>=

case '\n':
    if(in_cdir)
        {
        out_pos = 0;
        }
    else if(!in_string || (in_string && started_vcmnt) )
        {
        NEWLINE_TO_FORTRAN(NOT_CONTINUATION);

        if(in_string && started_vcmnt)@<Begin verbatim comment line@>@;
        }
    else if(!started_vcmnt)
        { /* Remember if  there's stuff in the buffer. If so, when
we terminate the verbatim comment we must continue. */
        should_continue = BOOLEAN(out_pos > rst_pos);

/* The next statement prevents overwriting the stuff already in the buffer. */
        if(should_continue) {NEWLINE_TO_FORTRAN(NOT_CONTINUATION);}
        should_continue = BOOLEAN((!free_Fortran) && should_continue);
        @<Begin verbatim c...@>;
        started_vcmnt = YES;
        }

    return;


@ The following stuff, which implements the \.{-d}~option, is kludgy and
obsolete; use \Ratfor\ instead.

@<Possibly number |do...@>=

if(number_dos && !continuation_line && (language==FORTRAN ||
        language==FORTRAN_90 || R66) )
    {
    outer_char HUGE *do_pos;

    do_pos = outp_buf + 6;

    if(out_pos == 9)
        {
        if(STRNCMP(do_pos,"do ",3)==0 && !isdigit(c))
            {
            sprintf((char *)(do_pos+=3),"%lu ",
                stmt_num[do_level++] = max_stmt++);

            while(*do_pos++ != '\0') out_pos++;
            }
        }
    else if( (out_pos==10 && STRNCMP(do_pos,"endd",4)==0) ||
            (out_pos==11 && STRNCMP(do_pos,"end d",5)==0) )
        {
        if(do_level == 0)
            {
            ERR_PRINT(T,"Too many END DOs");
            *outp_buf = 'C';
            }
        else
            {
            sprintf((char *)outp_buf,"%-5lu CONTINUE",
                stmt_num[--do_level]);
            out_pos = 14;
            return;
            }
        }
    }

@ Handle a newline when the output language is \Fortran.

@d NEWLINE_TO_FORTRAN(continuation_flag)
    flush_out(YES); // Write out the buffer.
    rst_out(continuation_flag)@; /* Reinitialize the buffer with no
continuation character. */

@ The following is used during output of verbatim comments.
@<Begin verbatim c...@>=
{
int k;

if(!meta_mode)
    {
    outp_buf[0] = begin_comment_char[lan_num(out_language)];

    for(out_pos = 1,k=spcs_after_cmnt; k; k--)
        outp_buf[out_pos++] = ' ';
    }

nbuf_length = MAX(t_style.output_line_length,80);
out_at_beginning = NO; // Prevents stripping off blanks at beginning of cmnt.
}

@ This routine writes out the current contents of \Fortran's output buffer.
@<Part 1@>=@[

SRTN flush_out FCN((prn_new_line))
    boolean prn_new_line C1("Do we print a newline?")@;
{
outp_buf[out_pos] = '\0'; // Terminate the buffer.

/* Dump it out, followed by a newline. */
WRITE1(outp_buf,out_pos)@;

if(prn_new_line)
    {
    PUTC(last_out='\n');
    flush0();
    }
}

@ After we've flushed the buffer, we must prepare it for the next stuff.

@d TO_BUFFER(type)
    if(!nuweb_mode)
        {
        px = t_style.meta[lan_num(language)].msg.type;
        STRCPY(outp_buf,px);
        out_pos = STRLEN(px);
        }

@<Part 1@>=@[

int rst_out FCN((continuation))
    boolean continuation C1("Is line a continuation?")@;
{
if(!continuation) RST_LAST_EXPR@; /* Reset the pointer so we can remember the
                    upcoming expression. */

/* Blank out the comment and label field (first five columns). */
for(out_pos=0; out_pos<5; ++out_pos)
    outp_buf[out_pos] = ' ';

/* Deposit the continuation character. */
outp_buf[out_pos++] = continuation ? t_style.cchar : (outer_char)' ';
continuation_line = continuation;
out_at_beginning = BOOLEAN(!continuation_line);

nbuf_length = t_style.output_line_length;

if(meta_mode)
    {
    if(!in_string)
        { /* Error message. */
        outp_buf[0] = begin_comment_char[lan_num(out_language)];
        if(!xpn_Ratfor) out_pos = 1 + spcs_after_cmnt;
        }

    nbuf_length = MAX(nbuf_length,80);
    }

/* If it's not a continuation line, mark the beginning. Also, if we're in a
loop, indent appropriately. */
if(out_at_beginning && xpn_Ratfor) blank_out(indent_level);

return rst_pos = out_pos;
}

@ Blank out columns appropriate to |indent_level|.
@<Part 1@>=@[

SRTN blank_out FCN((n))
    int n C1("Number of levels to indent.")@;
{
outer_char HUGE *p;
int i;

for(i=0,p=outp_buf+out_pos; i < n*INDENT_SIZE; i++) *p++ = ' ';

out_pos += i;
rst_pos = out_pos;
}

@*1 Index reversal.  For \Fortran\ programming, the \.{-)} option turns on
\It{index reversal}.  It converts constructions of the form `\.{a(k)(i)}'
to `\.{a(i,k)}', `\.{a(k(1)(2))(j)}' to `\.{a(j,k(2,1))}'.  As evidenced by
this last example, the procedure must be recursive.  It works as follows.
When a left parenthesis is recognized, the parenthesis level is advanced.
Output tokens are copied into a temporary buffer.  If the combination
`\.{)(}' is recognized, the buffer level is advanced and tokens are copied
into the new buffer.  This continues until a right parenthesis is
recognized.  Then the buffer levels are copied in reverse order to the
buffer of the previous parenthesis level, with commas inbetween.

The annoyance is how to treak `\.{)(}'.  There's no room for more tokens;
furthermore, the combination might be produced by macro processing.
Therefore, what actually happens when a right paren is seen is that a flag
|rparen| is set.  The buffers are not actually unwound at this time, but
deferred until the next character, where it can be decided whether `\.{)(}'
has occurred.  This is necessary because the output scheme cannot
conveniently look ahead; bytes are sent to |C_PUTC| one at a time.  The
disadvantage of this scheme is that white space sneaking inbetween the
parens will prevent the `\.{)(}' from being recognized (with the current
logic).

@d CUR_BUF (pai->text_buf[pai->ilevel])

@<Typedef...@>=

/* We'll manage the buffers with a structure.  That way, we can use a
standard routine |store| to add a byte. */
typedef struct
    {
    outer_char HUGE *start, HUGE *pos, HUGE *end;
    } TEXT_BUF;

/* One parenthesis level is described like this. */
typedef struct
    {
    int ilevel;    // Current buffer (index) level.
    TEXT_BUF HUGE *text_buf[10]; // Temporary storage for the index tokens.
    TEXT_BUF HUGE *last_buf; // Buffer of the previous level.
    } PAREN_LEVEL;

PAREN_LEVEL paren_level[10], HUGE *pai = paren_level;

int rparen = NO; // Was the last character a right paren?


@
@<Allocate dyn...@>=
{
pai->ilevel = 0;
pai->text_buf[0] = pai->last_buf = calloc(1, sizeof(TEXT_BUF));
}

@ Completed index levels are written into the appropriate |TEXT_BUF|, which
is initialized if necessary.  If we're at parenthesis level~0, we don't
store, but fire the byte at the \Fortran\ output buffer.

@<Part 1@>=@[

SRTN store FCN((t, c))
    TEXT_BUF HUGE *t C0("")@;
    outer_char c C1("")@;
{
if(pai == paren_level || t == paren_level[0].last_buf)
    { /* Send directly to \Fortran's output buffer. */
    buffer_out(c);
    return;
    }

/* Store in the indicated text buffer; initialize that if necessary. */
if(t->start == NULL)
    {
    t->pos = t->start = calloc(100, 1);
    t->end = t->start + 100;
    }

*t->pos++ = c;
}

@ Here we unwind the index entries in reverse order, interspersing them by
commas.  Unwinding one buffer entry just means copying it into the
|last_buf|.

@<Part 1@>=@[

SRTN unwind(VOID)
{
int i;
TEXT_BUF HUGE *t;
outer_char HUGE *s1;

if(pai == paren_level)
    {
    ERR_PRINT(T, "Missing '('");
    buffer_out(')');
    return;
    }

for(i=pai->ilevel; i >= 0; i--)
    {
    t = pai->text_buf[i];

    for(s1=t->start; s1<t->pos; s1++)
        store(pai->last_buf, *s1);

    t->pos = t->start; // Reset the buffer.

    if(i > 0)
        store(pai->last_buf, ',');
    }

store(pai->last_buf, ')');
pai--; // Decrement parenthesis level.
}


@ The following code is pressed into service with the `\.{-)}' flag (and
when one is not inside a character string).

@<Reverse \Fortran\ indices@>=
{
switch(c)
    {
   case '(':
    if(rparen)
        { /* The combination `\.{)(}' has occured; advance the
buffer level. */
        pai->ilevel++;

        @<Allocate |CUR_BUF| if necessary@>@;

        rparen = NO;
        }
    else
        { /* Time for a new parenthesis level.  Put the parenthesis
into the old level.  Remember where that was, then advance the level. */
        store(CUR_BUF, '(');

        (pai+1)->last_buf = CUR_BUF;
        pai++;
        pai->ilevel = 0;

        @<Allocate |CUR_BUF|...@>@;
        }

    break;

   case ')':
    if(!rparen)
        rparen = YES;
    else
        unwind();

    break;

   default:
    if(rparen)
        {
        unwind();
        rparen = NO;
        }

    store(CUR_BUF, c);
    break;
    }
}

@
@<Allocate |CUR_BUF|...@>=
{
if(!CUR_BUF)
    CUR_BUF = GET_MEM("CUR_BUF", 1, TEXT_BUF);
}

@i texts.hweb


@ Allocate the principal arrays.
@<Allocate dyn...@>=

alloc_Rat(); // Allocate \Ratfor\ arrays.

ALLOC(text,text_info,ABBREV(max_texts),max_texts,0);
text_end = text_info + max_texts - 1;

ALLOC(text,txt_dinfo,ABBREV(dtexts_max),dtexts_max,0);
textd_end = txt_dinfo + dtexts_max - 1;

ALLOC(eight_bits,tok_mem,ABBREV(max_toks_t),max_toks,0);
tok_m_end = tok_mem + max_toks - 1;

ALLOC(eight_bits,tok_dmem,ABBREV(max_dtoks),max_dtoks,0);
tokd_end = tok_dmem + max_dtoks - 1;

@ The convention is that the first entry, relating to the unnamed module,
has no replacement text. (The |CAST| operation was necessary to make the
Aztec compiler happy. Maybe it's not necessary anymore since we switched to
dynamic allocation.)
@<Set init...@>=

CAST(text_pointer,text_info)->tok_start = tok_ptr = tok_mem;
CAST(text_pointer,txt_dinfo)->tok_start = tok_dptr = tok_dmem;

  /* This makes replacement text 0 of length zero. */
text_ptr = text_info+1; text_ptr->tok_start = tok_mem;
txt_dptr = txt_dinfo + 1; txt_dptr->tok_start = tok_dmem;

@ If |p| is a pointer to a module name, |p->equiv| is a pointer to its
replacement text, an element of the array |text_info|.

@ The undefined module has no replacement text.

@<Set init...@>=

CAST(name_pointer,name_dir)->equiv = (EQUIV)text_info;

@ Here's the procedure that decides whether a name of length |l|
starting at position |first| equals the identifier pointed to by |p|:

@<Part 1@>=@[

boolean names_match FCN((p,first,l,dummy))
    name_pointer p C0("Points to the proposed match.")@;
    CONST ASCII HUGE *first C0("Position of first character of string.")@;
    int l C0("length of identifier.")@;
    eight_bits dummy C1("Not used here")@;
{
  if (length(p)!=l) return NO;
  return (boolean)(!STRNCMP(first,p->byte_start,l));
}

@ The |ini_node| operation differs for \FTANGLE\ and \FWEAVE.
@<Part 1@>=@[

SRTN ini_node FCN((node))
    CONST name_pointer node C1("")@;
{
node->equiv=(EQUIV)text_info;
@<Initialize |mod_info| and |Language|@>@;
}

@ Several procedures are called only by \.{WEAVE}, but null routines need
to be here so the linker doesn't complain.

@<Part 1@>=@[

SRTN ini_p FCN((p,t))
    name_pointer p C0("")@;
    eight_bits t C1("")@;
{}

SRTN open_tex_file(VOID)
{}

@* TOKENS.  Replacement texts, which represent code in a compressed format,
appear in |tok_mem| as mentioned above. The codes in these texts are called
`tokens'; some tokens occupy two consecutive eight-bit byte positions, and
the others take just one byte.

If $p$ points to a replacement text, |p->tok_start| is the |tok_mem|
position of the first eight-bit code of that text. If |p->text_link=macro
== 0|, this is the replacement text for a macro, otherwise it is the
replacement text for a module. In the latter case |p->text_link| is either
equal to |module_flag|, which means that there is no further text for this
module, or |p->text_link| points to a continuation of this replacement
text; such links are created when several modules have texts with the same
name, and they also tie together all the texts of unnamed modules.  The
replacement text pointer for the first unnamed module appears in
|text_info->text_link|, and the most recent such pointer is |last_unnamed|.

@d module_flag (sixteen_bits)max_texts /* Final |text_link| in module
                        replacement texts. */

@<Glob...@>=

EXTERN text_pointer last_unnamed; /* Most recent replacement text of
                    unnamed module. */

@
@<Set init...@>=

last_unnamed = text_info; // Root of the unnamed module.
CAST(text_pointer,text_info)->text_link = 0; // No unnamed pieces yet.

@ The following procedure is used to enter a two-byte value into
|tok_mem| when a replacement text is being generated.

@<Part 1@>=@[

SRTN store_two_bytes FCN((x))
    sixteen_bits x C1("Two-byte token to be entered into |tok_mem|.")@;
{
  if (tok_ptr+2>tok_m_end) OVERFLW("tokens",ABBREV(max_toks_t));

  *tok_ptr++ = (eight_bits)(x >> 8); // Store high byte.
  *tok_ptr++ = (eight_bits)(x & 0377); // Store low byte.
}

@i stacks.hweb

@ Dynamically allocate the stack.
@<Allocate dyn...@>=

ALLOC(output_state,stack,ABBREV(stck_size_t),stck_size,1);
stck_end = stack + stck_size; // End of |stack|.

@ To get the output process started, we will perform the following
initialization steps. We may assume that |text_info->text_link| is nonzero,
since it points to the \cee\ text in the first unnamed module that generates
code; if there are no such modules, there is nothing to output, and an
error message will have been generated before we do any of the initialization.

@d UNNAMED_MODULE 0

@<Initialize the output stacks@>=

stck_ptr = stack+1; cur_name = name_dir;
cur_repl = CAST(text_pointer,text_info)->text_link + text_info;
cur_byte = cur_repl->tok_start; cur_end = (cur_repl+1)->tok_start;
cur_mod = UNNAMED_MODULE;
params = cur_params = cur_global_params = global_params;
frz_params();

@ When the replacement text for name~|p| is to be inserted into the output,
the following subroutine is called to save the old level of output and get
the new one going.

We assume that the C compiler can copy structures.  (Certainly true for ANSI.)
@^system dependencies@>

@<Part 1@>=@[

SRTN push_level FCN((p,b0,b1))
    name_pointer p C0("The new replacement text.")@;
    CONST eight_bits HUGE *b0 C0("If |p == NULL|, beginning of new \
stuff in memory.")@;
    CONST eight_bits HUGE *b1 C1("If |p == NULL|, end of new stuff in \
memory.")@;
{
if(stck_ptr==stck_end) OVERFLW("stack levels",ABBREV(stck_size_t));

*stck_ptr = cur_state; // Save old state.

/* Initialize new state. */
cur_name = p;

if(p != NULL)
    {
    cur_repl = (text_pointer)p->equiv;

    if(cur_repl == NULL) CONFUSION("push_level","cur_repl is NULL");

    cur_byte = cur_repl->tok_start;
    cur_end = (cur_repl+1)->tok_start;
    }
else
    {
    cur_repl = NULL;

    cur_byte = (eight_bits HUGE *)b0; cur_end = (eight_bits HUGE *)b1;
    new_mbuf(); // Allocate new macro buffer. See \.{macs.web}.
    }

/* Get the language for this module. All modules start off in the global
language for that module. Also, the old state needs to recall the local
language switch. */
(stck_ptr++)->params = cur_params = cur_global_params =
    (p != NULL) ? params : params; /* ??? */
set_output_file(cur_language);
cur_mod = UNNAMED_MODULE; // Assume this until told otherwise.
}

@ When we come to the end of a replacement text, the |pop_level| subroutine
does the right thing: It either moves to the continuation of this replacement
text or returns the state to the most recently stacked level. If the pop
was successful---i.e., if there's more stuff to come---|YES| is returned.

@<Part 1@>=@[

boolean pop_level(VOID) /* do this when |cur_byte| reaches |cur_end| */
{
if(cur_repl != NULL && cur_repl->text_link < module_flag)
    { /* Link to a continuation---i.e., the next in the chain of
replacement texts for this module. */
    cur_repl = cur_repl->text_link + text_info; // Stay on the same level.
    cur_byte = cur_repl->tok_start;
    cur_end = (cur_repl+1)->tok_start;

/* In case we changed languages during the module, localize the change. */
    if(cur_repl->module_text)
        {
        params = cur_params = cur_global_params;
        frz_params();
        set_output_file(cur_language);
        }

    return YES;
    }

stck_ptr--; // Go down to the previous level.

if (stck_ptr>stack)
    {
    cur_state = *stck_ptr; // Copy the current state structure.
    set_output_file(cur_language);
    return YES; // Successfully descended to a lower active level.
    }

return NO; // Already at lowest level (top of stack).
}

@ The heart of the output procedure is the |get_output| routine, which
produces the next token of output that is not a reference to a macro. This
procedure handles all the stacking and unstacking that is necessary.  It
returns the value |module_number| if the next output begins or ends the
replacement text of some module, in which case |cur_val| is that module's
number (if beginning) or the negative of that value (if ending). (A module
number of 0 indicates not the beginning or ending of a module, but a
\&{\#line} command.)  And it returns the value |identifier| if the next
output is an identifier of length two or more, in which case |cur_val|
points to that identifier name.

@<Global...@>=

/* These harmlessly redefine stuff in \.{typedefs.web}. It's a bit shaky, but
it seems to work. One was running out of lower-order tokens. */

#undef begin_format_stmt
#define begin_format_stmt OCTAL(14)

#undef end_format_stmt
#define end_format_stmt OCTAL(15)

EXTERN long cur_val; /* Additional information corresponding to output
    token. This must be \It{signed} (and capable of handling a full
    |sixteen_bits|) because of trickery involving output of the module
    numbers. */

@ If |get_output| finds that no more output remains, it returns the
value~|NO|. Otherwise, it returns the next token after macro expansion.

@<Part 1@>=@[
eight_bits get_output(VOID)
{
sixteen_bits a; // Value of current byte.

restart:
  if (stck_ptr==stack) return NO; // At top of stack; nothing more.

  if (cur_byte==cur_end)
    {
    cur_val = -((long)cur_mod); /* When we end a module, |cur_val| is
set to the negative of the module number.  The cast is needed because of
sign extension. */

    if(cur_val != ignore) OUT_CHAR(module_number); /* Do this here so
it gets into the right file if we're changing languages. */

    pop_level();

    if (cur_val==ignore) goto restart;

    return module_number;
    }

@<Expand output byte@>@;
}

@ To get the saved stuff out, we need a slightly different version of the
|get_output| routine.
@<Part 1@>=@[

eight_bits get_saved_output FCN((stck_ptr0))
    stack_pointer stck_ptr0 C1("")@;
{
sixteen_bits a;

restart:
if(stck_ptr == stack || stck_ptr != stck_ptr0) return NO;

if(DONE_LEVEL)
    { /* Hunt for end-of-tokens mark. */
    if(!pop_level()) CONFUSION("get_saved_output",
        "Shouldn't encounter top level here");
    return ignore;
    }

@<Expand output byte@>@;
}

@ We will recover the saved stuff by pushing the stack ``by hand''. When
|is_expr| is true, we reset the pointer used to save expressions that
implement the two-token operators like `\.{*=}'. We also allocate a new
macro buffer on the stack, and switch to it, so that if macros are expanded
during the |copy_out|, things don't get overwritten. (This last stuff is
done by |push_level|.)
@<Part 1@>=@[

SRTN copy_out FCN((p0,p1,is_expr))
    CONST eight_bits HUGE *p0 C0("Start of memory buffer.")@;
    CONST eight_bits HUGE *p1 C0("End of memory buffer.")@;
    boolean is_expr C1("Flag for resetting pointer to last expression.")@;
{
stack_pointer stck_ptr0;

/* If we're copying out an expression, reset the memory pointer. */
if(is_expr) rst_last();

push_level(NULL,p0,p1);
stck_ptr0 = stck_ptr;
while(get_saved_output(stck_ptr0));
}

@ The character sent by |send_single|, below.
@<Glob...@>=

EXTERN eight_bits sent;

@ Occasionally, the next byte contains useful information. That's put into
|cur_val|, which can be processed by |out_char|.

@<Send a single-byte token, handling escapes such as
|begin_language| or |dot_const|@>=
{
send_single(a);
}

@  A function so we can interface to \.{rat77.web}.
@<Part 1@>=@[

SRTN send_single FCN((a))
    sixteen_bits a C1("")@;
{
boolean scope;

switch(a)
    {
   case begin_language:
/* |begin_language| escapes the actual language, which follows next. */
    switch(sent = *cur_byte++)
        {
       case NO_LANGUAGE: // Serves double-duty for |new_output_file|.
        scope = *cur_byte++;
        a = *cur_byte++;
        a = IDENTIFIER(a,*cur_byte++);
        new_out(scope,a);
        sent = new_output_file;
        break;

       @t\4@>@<Cases for appending a language switch@>;

       case NUWEB_OFF:
       case NUWEB_ON:
        nuweb_mode = BOOLEAN(0x0F & sent);
        break;

       case no_mac_expand:
        mac_protected = no_expand = YES;
        break;
        }
    break;

   case dot_const:
    cur_val = *cur_byte++; /* The relative number of the
operator is stored in the byte following |dot_const|. */
    sent = OUT_CHAR(a);
    break;

   default:
    sent = OUT_CHAR(a); // One-byte token.
    break;
    }
}

@ Open a new output file in response to an~\.{@@O} (global scope)
or~\.{@@o} (local scope) command.

@<Part 1@>=@[

#define TEMP_LEN (2*MAX_FILE_NAME_LENGTH)

SRTN new_out FCN((global_scope,a))
    boolean global_scope C0("0 for local, 1 for global")@;
    sixteen_bits a C1("")@;
{
name_pointer np = name_dir + a;
CONST ASCII HUGE *end;
size_t len;
outer_char temp_from[TEMP_LEN],temp_to[TEMP_LEN];
outer_char temp[MAX_FILE_NAME_LENGTH];

if(global_scope)
    {
    SPRINTF(TEMP_LEN,temp_from,
        `"\n\n  (This file was continued via @@O from %s.)",
        params.OUTPUT_FILE_NAME`);
    }
else
    {
    SPRINTF(TEMP_LEN,temp_from," ");
    }

/* Extract the file name from the |name_dir|. */
PROPER_END(end);
len = end - np->byte_start;
STRNCPY(temp,np->byte_start,len);
TERMINATE(temp,len);
to_outer((ASCII HUGE *)temp);
new_fname(¶ms.OUTPUT_FILE_NAME,temp,NULL);


if(global_scope)
    { /* Write a continuation message into the old file. */
    new_fname(&global_params.OUTPUT_FILE_NAME,temp,NULL);
    SPRINTF(TEMP_LEN,temp_to,`"  (Continued via @@O to %s.)",
        params.OUTPUT_FILE_NAME`);
    OUT_MSG(to_ASCII(temp_to),NULL);
    close_out(out_file);
    }
else
    fflush(out_file);

open_out(temp_from,global_scope);
}

#undef TEMP_LEN

@ The next fragment is used both here and in the \Ratfor-77 output routine.
@<Expand output byte@>=
{
a = *cur_byte++;

if (TOKEN1(a))
    {
    @<Send a single-byte token...@>;
    return sent;
    }
else
    {
    a = IDENTIFIER(a,*cur_byte++);

    switch (a/MODULE_NAME)
        {
       case 0:
        cur_val = a;
        @<Check for wild \Ratfor\ scan@>@;
        return OUT_CHAR(identifier);

       case 1:
        @<Expand module |a-MODULE_NAME|@>@;
        goto restart;

       default:
        cur_val = a - MODULE_NUM;
        if (cur_val>UNNAMED_MODULE) cur_mod = (sixteen_bits)cur_val;
/* Remember the current module so it can be used in
|out_char(module_number)| just after popping this level. */
        return OUT_CHAR(module_number); /* Module number at
beginning  of module. */
        }
    }
}

@ When checking for an out-of-control \Ratfor\ scan, we must look for the
following tokens:

@<Glob...@>=

IN_RATFOR sixteen_bits id_function,id_program,id_subroutine;

@ An errant \Ratfor\ scan can be stopped by looking for the beginning of
functions.

@<Check for wild \Ratfor...@>=
{
IN_RATFOR boolean balanced;
IN_RATFOR ASCII cur_delim;

if(!balanced && language==RATFOR &&
        (a == id_function || a == id_program || a==id_subroutine))
    {
    RAT_ERROR(ERROR,"Inserted missing '%c' at beginning of function",
        1,XCHR(cur_delim));
    cur_byte -= 2; // Process the current identifier again.
    return OUT_CHAR(cur_delim); // Insert delimiter being searched for.
    }
}

@ When we expand a module, we remember the value for possible use in the
|_MODULE_NAME| macro.

@<Glob...@>=

EXTERN sixteen_bits cur_mod_no SET(0);

@ Implement the \.{\_MODULE\_NAME} built-in.

@<Define internal macros@>=

SAVE_MACRO("_MODULE_NAME $STRING($$MODULE_NAME)");
SAVE_MACRO("$MODULE_NAME $STRING($$MODULE_NAME)");

@
@d UNNAMED_MOD "unnamed"
@<Part 1@>=@[

SRTN i_mod_name_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
int len;
name_pointer np = cur_name;
eight_bits HUGE *p;

CHK_ARGS("$MODULE_NAME",0);

if(cur_name) cur_mod_no = np - name_dir;
else cur_mod_no = 0;

len = cur_mod_no ? length(np) : STRLEN(UNNAMED_MOD);
MCHECK(len,"current module name");

if(cur_mod_no)
    for(p=np->byte_start; p<(np+1)->byte_start; )
        *mp++ = *p++;
else
    {
    STRCPY(mp,UNNAMED_MOD);
    to_ASCII(mp);
    mp += len;
    }
}

@ Here's the number corresponding to the current module name.
@<Part 1@>=@[

SRTN i_sect_num_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
num_to_mbuf(n,pargs,"$SECTION_NUM",0,"section number",cur_mod);
}

@ The user may have forgotten to give any code text for a module name,
or the code text may have been associated with a different name by mistake.

@<Expand module |a-...@>=
{
name_pointer np;

a -= MODULE_NAME;

np = name_dir + a;

if(np->equiv != (EQUIV)text_info) push_level(np,NULL,NULL);
else if(a != UNNAMED_MODULE)
    { /* Module definition missing. */
    SET_COLOR(error);
    printf("\n! Not present: <"); prn_id(np); ERR_PRINT(NULL,">");
@.Not present: <section name>@>
    SET_COLOR(ordinary);
    @<Output a function call for debugging purposes@>@;
    }
}

@ When a missing module is detected, the command `\.{\$STUB(\It{name})}' is
inserted.  That macro expands by default to a function call appropriate to
the current language.

@<Define internal macros@>=

SAVE_MACRO("_STUB(s)$IFCASE($LANGUAGE_NUM,\
{missing_mod(#s);},{missing_mod(#s);},\
call nomod(#s),call nomod(#s),\
call nomod(#s),call nomod(#s),\
\\missingmod{s},\
%nomod(s),%nomod(s))");

SAVE_MACRO("$STUB(s)$IFCASE($LANGUAGE_NUM,\
{missing_mod(#s);},{missing_mod(#s);},\
call nomod(#s),call nomod(#s),\
call nomod(#s),call nomod(#s),\
\\missingmod{s},\
%nomod(s),%nomod(s))");

@ Here we build the tokenized text to make a call to a stub routine that
serves as the text of an undefined module.
@<Output a function call for debugging...@>=
{
#define TEMP_LEN 300

eight_bits temp[TEMP_LEN],temp1[TEMP_LEN];
sixteen_bits stub;
size_t n = length(np);

id_first = x__to_ASCII(OC("$STUB"));
stub = ID_NUM(id_first,id_first+5);

STRNCPY(temp1,np->byte_start,n);
temp1[n] = '\0';

SPRINTF(TEMP_LEN,temp,`"%c%c%c%c%s%c%c",
    LEFT(stub,ID0),RIGHT(stub),@'(',stringg,temp1,stringg,@')'`);
push_level(NULL,temp,temp+STRLEN(temp));

#undef TEMP_LEN
}

@ Interface to \.{rat77.web}.
@<Part 1@>=@[

SRTN x_mod_a FCN((a))
    sixteen_bits a C1("")@;
{
@<Expand module |a...@>@;
}

@* PRODUCING the OUTPUT.  The |get_output| routine above handles most of
the complexity of output generation, but there is one further consideration
that has a nontrivial effect on \.{TANGLE}'s algorithms.  Namely, we want
to make sure that the output has spaces and line breaks in the right places
(e.g., not in the middle of a string or a constant or an identifier, not at
a `\.{@@\&}' position where quantities are being joined together, and, if
in the C~language, certainly after a `\.=' because the C compiler thinks
`\.{=-}' is ambiguous).

The output process can be in one of following states (which are |enum|ed in
\.{typedefs.web}):

\yskip\hang |NUM_OR_ID| means that the last item in the buffer is a number or
identifier, hence a blank space or line break must be inserted if the next
item is also a number or identifier.

\yskip\hang |UNBREAKABLE| means that the last item in the buffer was followed
by the \.{@@\&}~operation that inhibits spaces between it and the next item.

\yskip\hang |VERBATIM| means we're copying only character tokens, and
that they are to be output exactly as stored.  This is the case during
strings, verbatim constructions and numerical constants.

\yskip\hang |MISCELLANEOUS| means none of the above.

\yskip Furthermore, if the variable |protect| is positive, new-lines
are preceded by the value of the style-file field |protect|.

@<Global...@>=

EXTERN OUTPUT_STATE out_state; // Current status of partial output.
EXTERN boolean protect; // Current status of partial output.
EXTERN boolean copying_macros SET(NO); // Outputting outer macros?
EXTERN boolean in_cdir SET(NO); // Inside a compiler directive?

@ Here is a routine that is invoked when we want to output the current line.
During the output process, |cur_line| equals the number of the next line
to be output. This variable counts the total number of lines that have been
output. However, this is not useful for error messages when more than one
file are open. Thus, we introduce an array |outp_line| of current lines
that keeps track of what's going on in each individual language.  The
output line number for the current language is accessed by the macro
|OUTPUT_LINE|.

@d flush_buffer() C_putc('\n')

@<Part 1@>=@[

SRTN flush0()
{
/* This routine might be called during phase~1, because error messages use
the output buffering routines.  However, we don't want to update
|cur_line|, which counts the input lines during phase~1. */
if(phase==1) return;

/* Give some feedback to the terminal by printing a dot every so often, and
the line number somewhat less often. */
if (cur_line % 100 == 0)
    {
    if (cur_line % 500 == 0) {CLR_PRINTF(line_num,("%u",cur_line));}
    else putchar('.');

    UPDATE_TERMINAL; // Progress report.
    }

cur_line++;
OUTPUT_LINE++;
}

@* The BIG OUTPUT SWITCH.  Here then is the routine that does the
output:

@<Part 1@>=@[

SRTN phase2(VOID)
{
phase = 2;

params = global_params;
frz_params();
set_output_file(global_language);

/* Get the FORTRAN output buffer ready. */
rst_out(NOT_CONTINUATION);

CLR_PRINTF(info,("\nWriting the %soutput file(s):",
    compare_outfiles ? "temporary " : ""));
printf("  ");
UPDATE_TERMINAL;

cur_line = 1;

if (CAST(text_pointer,text_info)->text_link==0)
    { /* There was no program text. */
    CLR_PRINTF(warning, ("\n! No program text was specified."));
    mark_harmless;
@.No output was specified@>
      }
else
    { /* There is program text. */
    @<Truncate identifiers@>;

    @<Initialize the output stacks@>;
    @<Output macro definitions@>;

    @<Initialize the output stacks@>;

    while(get_output())
        ; // Process each character of the output.

    flush_buffer();

    if(compare_outfiles)
        cmp_outfiles(); // Compare tangled output against old files.

    CLR_PRINTF(info,("\nDone."));
    }
}

@ The command line is written out at the very beginning of the output file
as a meta-comment.
@<Part 1@>=@[
SRTN out_version FCN((msg))
    CONST outer_char *msg C1("")@;
{
outer_char HUGE *temp = GET_MEM("version:temp",N_MSGBUF,outer_char);
boolean in_string0 = in_string;
OUTPUT_STATE out_state0 = out_state;

SPRINTF(N_MSGBUF,temp,
    `"  FTANGLE v%s, created with %s on \"%s, %s at %s.\" %s\n",
    $VERSION,the_system,$DAY,$DATE,$TIME,local_banner`);
STRCAT(temp,cmd_ln_buf);
STRCAT(temp,msg); // Possible \.{@@o} continuation message.i
in_version = YES;
OUT_MSG(to_ASCII(temp),NULL);
FREE_MEM(temp,"version:temp",N_MSGBUF,outer_char);

in_version = NO;
in_string = in_string0;
out_state = out_state0;

if(line_info)
    out_pos = 0;
else
    {
    started_vcmnt = NO;
    rst_out(NOT_CONTINUATION);
    }
}

@ The version number is defined as the string |version| in \.{common.web}.
@<Define internal macros@>=

SAVE_MACRO("_VERSION $STRING($$VERSION)");
SAVE_MACRO("$VERSION $STRING($$VERSION)");

@ This internal function just puts the version number into the |macro_buf|.
@<Part 1@>=@[

SRTN i_version_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
CHK_ARGS("$VERSION",0);

mcopy(version);
}

@ Here are the various time and date macros.

@m __DAY 0
@m __DATE 1
@m __TIME 2

@m STORE_TIME(macro,i)STORE_TIME0(#!macro $TM(i))
@m STORE_TIME0(s)SAVE_MACRO(#s)

@<Define internal macros@>=

STORE_TIME(_DAY,__DAY);
STORE_TIME(_DATE,__DATE);
STORE_TIME(_TIME,__TIME);

STORE_TIME($DAY,__DAY);
STORE_TIME($DATE,__DATE);
STORE_TIME($TIME,__TIME);

SAVE_MACRO("_TM(i)$STRING($$TM(i))");
SAVE_MACRO("$TM(i)$STRING($$TM(i))");

@ The date and time functions use the ANSII standard routines.
@<Part 1@>=@[

SRTN i_tm_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
eight_bits HUGE *p;
struct tm *t;

CHK_ARGS("$TM",1);

p = pargs[0] + 1; // Should point to a single-digit constant.

if(*p++ != constant)
    {
    MACRO_ERR("Argument of $TM must be numerical constant",YES);
    return;
    }

t = the_localtime(); // Fill the |tm| structure and return a pointer.

switch(*p - @'0')
    { /* Convert digit to integer and select routine. */
    case __DAY:
        mcopy(the_day(t));
        break;

    case __DATE:
/* The date needs to be protected because of the comma. */
        MCHECK(2,"the_cdate");
        *mp++ = @'`';
        mcopy(the_cdate(t));
        *mp++ = @'`';
        break;

    case __TIME:
        mcopy(the_time(t));
        break;

    default:
        MACRO_ERR("Invalid case in _tm_",YES);
        break;
    }
}

@ Here is a simple routine that copies an |outer_char| string into the
|macro_buf|, converting to |ASCII| as it does so.
@<Part 1@>=@[

SRTN mcopy FCN((s))
    CONST outer_char *s C1("")@;
{
int n = STRLEN(s);

MCHECK(n,"mcopy");
STRCPY(mp,x_to_ASCII(s));
mp += n;
}

@ First we go through the list of replacement texts and copy to the output
the macros that were defined by~\.{@@d}. These will be preceded by the
preprocesor \.{define} command appropriate for the language of that macro.

For the future, we really ought to have a mechanism that starts this list
after some position in the file that may not be the top.  That way,

@<Output macro def...@>=
@{
sixteen_bits a;
text_pointer cur_text;
boolean is_def;

@b
copying_macros = YES;

for (cur_text=text_info+1; cur_text<text_ptr; cur_text++)
  if (cur_text->text_link==macro)
    { /* |cur_text| is the text for a macro */
        cur_byte=cur_text->tok_start;
        cur_end=(cur_text+1)->tok_start;

    is_WEB_macro =
        BOOLEAN(!((is_def=BOOLEAN(cur_text->nargs==OUTER_MACRO)) ||
            cur_text->nargs==OUTER_UNMACRO)); /* Check special
marker set on input. */

    if(is_WEB_macro)
        {
#if(0)
        see_macro(cur_byte,cur_end) /* For debugging. */
#endif
        ;}
    else
        @<Copy outer macro.@>@;
    }

copying_macros = NO;
}

@ Here we copy the non-WEB ``outer'' macros to the output. At the moment,
these always go to the very top of the output. This is not always
convenient, and someday we'll generalize.

@<Copy outer...@>=
{
LANGUAGE language0;
T_OUTER *po = &t_style.outer_start[lan_num(language)];
outer_char *outer_macro;

out_state = MISCELLANEOUS;

set_output_file((LANGUAGE)cur_text->Language); /* Set the language for this
                        outer macro.  */

protect = YES; // New-lines should be preceded by the protection character.

outer_macro = OC(is_def ? po->def : po->undef);
language0 = language;

C_sprintf(outer_macro,0);

stck_ptr = stack;
push_level(NULL,cur_byte,cur_end);

WHILE()
    @<Write one outer macro@>@;

set_output_file(language0);

protect = NO;
flush_buffer();
}

@
@<Write one outer macro@>=
{
if(DONE_LEVEL && !pop_level()) break;

a = *cur_byte++;

if (cur_byte==cur_end && a==@'\n')
    continue;    // disregard a final new-line

if (TOKEN1(a))
    @<Send a single-byte token...@>@;
else
    {
    a = IDENTIFIER(a,*cur_byte++);

        if (a<MODULE_NAME)
        {
            cur_val=a;
        OUT_CHAR(identifier);// Outer macro text will be expanded here.
            }
        else if (a!=MODULE_NUM)
        {
        CONFUSION("copy outer","Macros defs have strange char");
        }
    else
        {
            cur_mod = a - MODULE_NUM;
        cur_val = (long)cur_mod;
        OUT_CHAR(module_number);
            }
    /* no other cases */
        }
}

@ If the switch |truncate_ids| is on, then we go through the list of
identifiers, strip off selected characters, and maybe truncate them.
(The code for truncating identifiers isn't completed in version~1.)

@<Truncate id...@>=
{
name_pointer np;

npmax = name_ptr - 1; // Used in output routine.

if(truncate_ids)
    {
    unsigned n = 0; // Counts number of truncations.

    printf("\nTruncating %u identifiers...",name_ptr - name_dir);

    for(np=name_dir+1; np<name_ptr; np++)
        n += trunc_id(np);

    printf("\n%u truncation(s) performed.",n);
    }

not_unique(); // Print non-unique identifiers.
}

@ Check for duplicate identifiers.

@d NEWLINE puts("")

@f TRUNC int
@f BP int

@<Part 1@>=@[

SRTN not_unique(VOID)
{
TRUNC HUGE *s,HUGE * HUGE *ss,HUGE * HUGE *ss0,HUGE * HUGE *ss1;
LANGUAGE Language;
int l;
size_t n; // Counts number of non-unique variables.
size_t num_max; // Maximum \# of roots for any duplicate.
BP HUGE * HUGE *bb0;
boolean found_dup = NO;

for(l=0; l<NUM_LANGUAGES; l++)
    {
    Language = lan_enum(l);

/* Count the number of duplicate variables. */
    n = 0;

    for(s=&sh; s->next; s=s->next)
        {
        if(!((boolean)s->Language & (boolean)Language)) continue;

        if(s->num[l] > 1)
            {
            char temp[10];
            unsigned len = tr_max[l];

            sprintf(temp,len ? "%u" : "*",len);

            if(n==0)
                {
                printf("\n\n%c! Non-unique \
%s variables (filtered with {%s}, truncated to length %s):",
                beep(1),languages[l],filter_char[l],temp);
                found_dup = YES;
                }
            n++;
            }
        }

    if(n == 0) continue;

/* Store the pointers to the duplicates in an array. */
    ss1 = ss0 = ss = GET_MEM("ss",n,TRUNC HUGE *);
    num_max = 0;

    for(s=&sh; s->next; s=s->next)
        {
        if(!((boolean)s->Language & (boolean)Language)) continue;

        if(s->num[l] > 1)
            {
            *ss++ = s;
            num_max = MAX(num_max,s->num[l]);
            }
        }

/* Sort the array. */
    QSORT(ss0,n,sizeof(TRUNC HUGE *),cmpr_trunc);

/* Print out the sorted array. */
    bb0 = GET_MEM("bb",num_max,BP HUGE *);

    while(ss1 < ss)
        see_dup(*ss1++,Language,bb0);

    FREE_MEM(ss0,"ss",n,TRUNC HUGE *);
    FREE_MEM(bb0,"bb",num_max,BP HUGE *);
    }

if(found_dup)
    NEWLINE;
}

SRTN see_dup FCN((s,Language,bb0))
    CONST TRUNC HUGE *s C0("")@;
    LANGUAGE Language C0("")@;
    BP HUGE *HUGE *bb0 C1("")@;
{
BP HUGE *b, HUGE * HUGE *bb, HUGE * HUGE *bb1;
int n;

NEWLINE;
printf(" ");
n = see(s->id,s->id_end); // The truncated id.

/* Space it out so it looks nicely lined up. */
for(n = tr_max[lan_num(Language)] + 1 - n; n > 0; n--) printf(" ");
printf("<=");

/* Print all back references to original variables. */
for(b=s->first,bb=bb0; b != NULL; b=b->next)
    {
    if(!((boolean)b->Language & (boolean)Language)) continue;

    *bb++ = b;
    }

QSORT(bb0,bb-bb0,sizeof(BP HUGE *),cmpr_bp);

for(bb1=bb0; bb1<bb; bb1++)
    {
    printf(" ");
    see((*bb1)->byte_start,(*bb1)->byte_end);
    }
}

int see FCN((c0,c1))
    CONST ASCII HUGE *c0 C0("Beginning.")@;
    CONST ASCII HUGE *c1 C1("end.")@;
{
int n = c1 - c0;

while(c0 < c1) printf("%c",XCHR(*c0++));

return n; // Length of identifier.
}

@
@<Part 1@>=@[

int cmpr_trunc FCN((t0,t1))
    TRUNC HUGE **t0 C0("")@;
    TRUNC HUGE **t1 C1("")@;
{
switch(web_strcmp((*t0)->id,(*t0)->id_end,(*t1)->id,(*t1)->id_end))
    {
   case EQUAL:
    return 0;

   case LESS:
   case PREFIX:
    return -1;

   case GREATER:
   case EXTENSION:
    return 1;
    }

return 0;
}

int cmpr_bp FCN((bb0,bb1))
    BP HUGE **bb0 C0("")@;
    BP HUGE **bb1 C1("")@;
{
switch(web_strcmp((*bb0)->byte_start,(*bb0)->byte_end,
        (*bb1)->byte_start,(*bb1)->byte_end))
    {
   case EQUAL:
    return 0;

   case LESS:
   case PREFIX:
    return -1;

   case GREATER:
   case EXTENSION:
    return 1;
    }

return 0;
}

@i trunc.hweb

@ Define the first truncation structure.
@<Glob...@>=

EXTERN TRUNC sh;

@ Attach a back-pointer structure to a |TRUNC| structure.
@<Part 1@>=@[

BP HUGE *b_link FCN((s,Language,p0,p1))
    TRUNC HUGE *s C0("")@;
    LANGUAGE Language C0("")@;
    CONST ASCII HUGE *p0 C0("")@;
    CONST ASCII HUGE *p1 C1("")@;
{
BP HUGE *bp;

bp = GET_MEM("bp",1,BP); /* Get a back-pointer structure. */

bp->c = BP_MARKER;

/* Remember language of original variable. */
bp->Language = Language;

/* Record start and end of the original name. */
bp->byte_start = p0;
bp->byte_end = p1;

/* Link back to original |TRUNC| structure. */
bp->Root = s;
s->Language |= (boolean)Language;
s->num[lan_num(Language)]++; /* Count hits for this language. */

return bp;
}

@
Attach a |TRUNC| structure to the chain of truncated ids.
@<Part 1@>=@[

TRUNC HUGE *s_link FCN((s,id,len))
    TRUNC HUGE *s C0("Points to the current structure, to be \
filled with info.")@;
    CONST ASCII HUGE *id C0("Truncated identifier.")@;
    unsigned short len C1("Length of truncated identifier.")@;
{
/* Fill this structure with truncated variable name. */
s->id = GET_MEM("s->id",len,ASCII); // Space for name.
STRNCPY(s->id,id,len); // Copy over name.
s->id_end = s->id + len; // End of name.

/* Attach another (uninitialized) structure. */
s->next = GET_MEM("s->next",1,TRUNC);

return s;
}

@ Search for identifier in table.
@<Part 1@>=@[

name_pointer id0_lookup FCN((start,end,l))
    CONST ASCII HUGE *start C0("Start of name.")@;
    CONST ASCII HUGE *end C0("end of name.")@;
    LANGUAGE l C1("")@;
{
name_pointer np;
CONST ASCII HUGE *p0, HUGE *p1;

for(np=name_dir+1; np<name_ptr; np++)
    {
    if(!(np->Language & (boolean)l) ||
        np->equiv != NULL || *(p0=np->byte_start) == BP_MARKER)
            continue;

    PROPER_END(p1);

    if(web_strcmp(p0,p1,start,end) == EQUAL)
        return np;
    }

return NULL;
}

@ Test if a character~|c| is valid for an identifier in the $l$th~language.
@<Unused@>=

boolean valid_char FCN((c,l))
    ASCII c C0("Character to be tested.")@;
    int l C1("Language index.")@;
{
return BOOLEAN(STRCHR(filter_char[l],(int)XCHR(c)) == NULL);
/* If the character isn't a filter character, we return |YES|. */
}

@ Truncate an identifier.
@<Part 1@>=@[

unsigned trunc_id FCN((np0))
    CONST name_pointer np0 C1("Points to current id structure.")@;
{
CONST ASCII HUGE *p, HUGE *p0, HUGE *p1; // For original identifier.
ASCII temp[N_IDBUF];
ASCII HUGE *t; // For truncated identifier.
unsigned short n; // Length of truncated identifier.
TRUNC HUGE *s;
name_pointer np;
unsigned short nmax; // Truncate to this length.
LANGUAGE Language;
int l;
unsigned count = 0;

if(np0->Language == (boolean)NO_LANGUAGE || np0->equiv != NULL)
    return 0;

for(l=0; l<NUM_LANGUAGES; l++)
 {
Language = lan_enum(l);
np = np0;

/* Don't bother with it if there's no truncation specified for this
language, if it's not in use for this language, if it's a reserved word,
intrinsic word, or keyword, or if it's a \WEB\ macro. */
 if( (nmax = tr_max[l]) == 0 || !(np->Language & (boolean)Language)
    || (np->reserved_word & (boolean)Language)
    || (np->intrinsic_word & (boolean)Language)
    || (np->keyword & (boolean)Language)
    || (np->macro_type != NOT_DEFINED) )
        continue;

/* The original name. */
p0 = np->byte_start;

if(*p0 == BP_MARKER)
    continue; /* NEED MORE WORK HERE (variable already deflected). */

PROPER_END(p1);

/* Filter. */
for(p=p0,t=temp,n=0; p<p1 && n<nmax; p++)
    if(STRCHR(filter_char[l],(int)XCHR(*p)) == NULL)
        {
        n++;
        *t++ = *p;
        }

n = t - temp; // Length of truncated identifier.

if(p1-p0 == (long)n)
    continue; // Not truncated; nothing to do.

count++; // Count number of truncations for this identifier.

/* Is the truncated name already in the list? */
for(s= &sh; s->next != NULL; s=s->next)
    if(s->id_end - s->id == (long)n &&
            web_strcmp(s->id,s->id_end,temp,t) == EQUAL)
        {
    another_bp:
        s->last = s->last->next = b_link(s,Language,p0,p1);
/* Remember the original variable by attaching another back reference. */
        np->byte_start = (ASCII *)s->last; // Deflect original ptr.
        goto next_language;
        }

/* Add a new name to the list. */
s = s_link(s,temp,n);
s->first = s->last = b_link(s,Language,p0,p1); // Attach first back reference.
np->byte_start = (ASCII *)s->first; // Deflect original ptr.

/* If the truncated name was in the original list, not previously truncated
from something else, put the original name into the truncated list. */
if( (np = id0_lookup(temp,t,(LANGUAGE)np->Language)) != NULL)
    {
    p0 = np->byte_start; PROPER_END(p1);
    goto another_bp;
    }

next_language:;
 }

return count;
}

@ Here are some flags used in the output routine |out_char|.
@<Glob...@>=

EXTERN boolean mac_protected SET(NO); /* Are we between left quotes, so macros
                shouldn't be expanded? */
EXTERN boolean send_rp SET(NO); /* Takes on a value only for |language ==
    RATFOR || language==FORTRAN|, when it's used to enclose the rhs of
    an operator like \.{*=}. */

EXTERN boolean in_version SET(NO); // For the initial header of output file.
EXTERN T_META *pmeta;

@ This fragment finishes off a~\.{*=} or similar operator by enclosing the
right-hand side expressions in parentheses.
@<Maybe send a right parenthesis@>=

if(send_rp)
    {
    C_putc(')');
    send_rp = NO; // Clear the flag.
    }

@ A many-way switch, |out_char()|, is used to send the output. Because of
macro expansion, this routine needs to be  recursive. It performs a variety
of actions, including inserting spaces at desired places (such as after
equals and between identifiers), translating internal codes to their
visible representations such as~\.{++}, etc.

@<Part 2@>=@[

eight_bits out_char FCN((cur_char))
    eight_bits cur_char C1("Token to control or be sent to the output.")@;
{
switch(cur_char)
    {
   case ignore:
    if(R77_or_F && started_vcmnt) C_putc(cur_char);
    return @' '; /* KLUDGE  to prevent |get_output| from being
terminated prematurely. */

/* In nuweb mode, tab is mapped to bell on input, and back again here. */
   case bell:
    return out_dflt(tab_mark);
@%   case bell: break; /* Bells go to the tty, but not the output file. */

   case @',':
    out_dflt(cur_char);
    @<Mark split position@>@;
    break;

   case interior_semi:
    if(!(Fortran88||in_string)) cur_char = @';';
        // Fall through to regular semicolon.

   case @';':
    @<Maybe send a right paren...@>;
    return out_dflt(cur_char);

   case cdir:
    in_cdir = BOOLEAN(!in_cdir);
    if(FORTRAN_LIKE(language))
        {
        in_string = NO;
        flush_buffer();
        in_string = YES;
        }
    break;

   case @'\n':
    if((copying_macros || !nuweb_mode)
            && (protect || out_state==VERBATIM) )
        {
/* Outer macros are absorbed with no explicit backslash at end of line.
Furthermore, spaces are stripped from the start of the next line.
Therefore, we will think of the end of line as a space.  Contrast this with
explicit \.{\#define}'s continued with a backslash, which just abuts the
last character of the line with the first character of the next one. */
        if(copying_macros && protect)
            C_putc(' ');

        out_str(t_style.protect_chars[lan_num(language)]);
            /* Backslash at end of line. */
        }
    @<Maybe send a right paren...@>;
    flush_buffer();
    if (out_state!=VERBATIM)
        out_state = MISCELLANEOUS;
    break;

   @t\4@>@<Case of an identifier@>;
   @t\4@>@<Case of a module number@>;
   @t\4@>@<Cases like \.{!=}@>;
   @t\4@>@<Cases like \.{+=}@>;

   case @'=':
    C_putc('=');
    if (out_state!=VERBATIM)
        {
        if(C_LIKE(language) && !nuweb_mode)
            C_putc(' '); // Space after equals.

        out_state = MISCELLANEOUS;
        }
    @<Mark split position@>@;
    break;

   case join: out_state = UNBREAKABLE; break;

   case constant:
    if (out_state==VERBATIM)
        out_state= in_format ? MISCELLANEOUS : NUM_OR_ID;
            // End of constant.
    else
        { /* Beginning of constant. */
        @<Mark split...@>@;

            if(out_state==NUM_OR_ID && !nuweb_mode)
            C_putc(' ');

        out_state = VERBATIM;
        }

    in_constant = BOOLEAN(!in_constant);
    break;

   case stringg:
    if(in_string)
        out_state = MISCELLANEOUS; // End of string.
        else
        { /* Begining of string. */
        @<Mark split...@>@;

        if(out_state == NUM_OR_ID && !nuweb_mode)
            C_putc(' '); /* Strings after
identifiers can happen in macro definitions. */

        out_state = VERBATIM;
        }

    in_string = BOOLEAN(!in_string);
    break;

   case begin_meta:
/* If there are two |begin_meta|s in a row, the second one means to turn
off the |xpn_Ratfor| flag, which among other things is used to control the
spacing after the comment character in \Fortran\ output. */
    pmeta = &t_style.meta[lan_num(language)];

    switch(language)
        {
        outer_char *t;

       case C:
       case C_PLUS_PLUS:
       case LITERAL:
       case TEX:
        if(meta_mode) break;

        if(!nuweb_mode)
            {
            if(in_string && !in_version)
                OUT_STR(t=pmeta->msg.top);
            else
                OUT_OP(t=pmeta->hdr.top);

            if(*t) OUT_STR("\n"); // Necessary????
            }
        meta_mode = YES;
        break;

       case RATFOR:
       case RATFOR_90:
       case FORTRAN:
       case FORTRAN_90:
        if(meta_mode)
            xpn_Ratfor = NO;
         C_putc(cur_char);
        out_state = MISCELLANEOUS;
        break;

       default:
        CONFUSION("out_char:begin_meta","Language not defined");
        }
    break;

   case end_meta:
    meta_mode = NO;

    switch(language)
        {
        outer_char *t;

       case C:
       case C_PLUS_PLUS:
       case LITERAL:
       case TEX:
        if(meta_mode) break;

        if(!nuweb_mode)
            {
            if(in_string && !in_version)
                OUT_OP(t=pmeta->msg.bottom);
            else
                OUT_OP(t=pmeta->hdr.bottom);

            if(*t) OUT_OP("\n"); // Necessary????
            }
        break;

       case RATFOR:
       case RATFOR_90:
       case FORTRAN:
       case FORTRAN_90:
        xpn_Ratfor = YES;
        C_putc(cur_char);
        out_state = MISCELLANEOUS;
        break;

       default:
        CONFUSION("out_char:end_meta","Language not defined");
        }

    break;

   case @'{':
    if(R77 && !in_string)
        @<Copy function body@>@;
    else
        {
        @<Mark split...@>@;
        return out_dflt(cur_char);
        }
    break;

/* The following doesn't work right when there's no |program| statement. */
   case @'}':
    {
    if(R77 && !in_string && brace_level==0)
        RAT_ERROR(WARNING,"Spurious '}' ignored, \
or missing program, module, subroutine, or function statement",0);
    else
        {
        out_dflt(cur_char);
        @<Mark split...@>@;
        }
    }

    break;

   case @'[':
    out_bracket(cur_char,@'(');
    break;

   case @']':
    out_bracket(cur_char,@')');
    break;


   case @'`':
    if(!(in_string || language==LITERAL))
        {
        mac_protected = BOOLEAN(!mac_protected);
        break;
        }
    else
        return out_dflt(cur_char);

   case @'&':
    if(C_LIKE(language) && out_state != VERBATIM
            && *(pC_buffer-1) == '&' && !nuweb_mode)
        C_putc(' '); // Handle the situation |x & &y|.
    @<Mark split...@>@;
    return out_dflt(cur_char);

   case @'\\':
    if(R66)
        cur_char = @'$'; /* Change octal constant to \Ratfor's
argument token. This is kludgy and obsolete. */

   default:
    return out_dflt(cur_char);
    }

return cur_char;
}

@
@<Part 2@>=@[

eight_bits out_bracket FCN((cur_char,new_char))
    eight_bits cur_char C0("")@;
    eight_bits new_char C1("")@;
{
if(out_state != VERBATIM && FORTRAN_LIKE(language) && translate_brackets)
    cur_char = new_char;
return out_dflt(cur_char);
}

@
@<Mark split...@>=
{
#if FANCY_SPLIT
    if(C_LIKE(language) && out_state!=VERBATIM)
        split_pos = pC_buffer;
#endif /* |FANCY_SPLIT| */
}

@ In \Ratfor-77 mode, when we sense an opening brace, we copy everything
between matched braces.
@<Copy function body@>=
{
cp_fcn_body(); /* See \.{rat77.web}. */
cur_char = 01;
}

@ Send a single character to the output.
@<Part 2@>=@[

eight_bits out_dflt FCN((c))
    eight_bits c C1("")@;
{
C_putc(XCHR(c));

if (out_state != VERBATIM)
    out_state = MISCELLANEOUS;

return c;
}

@
@<Cases for appending a lan...@>=

case C: opn_output_file(C); @+ break;
case C_PLUS_PLUS: opn_output_file(C_PLUS_PLUS); @+ break;
case RATFOR:
    if(!RAT_OK("(send_single)"))
        CONFUSION("output default","Ratfor command during output");
    opn_output_file(RATFOR);
    break;
case RATFOR_90:
    if(!RAT_OK("(send_single)"))
        CONFUSION("output default","Ratfor command during output");
    opn_output_file(RATFOR_90);
    break;
case FORTRAN: opn_output_file(FORTRAN); @+ break;
case FORTRAN_90: opn_output_file(FORTRAN_90); @+ break;
case TEX: opn_output_file(TEX); @+ break;
case LITERAL: opn_output_file(LITERAL); @+ break@;

@ When we switch languages, we must select the appropriate output file, and
set up any relevant parameters.

@<Part 2@>=@[

LANGUAGE set_output_file FCN((language0))
    LANGUAGE language0 C1("")@;
{
language = language0; // Set the input language.
out_file = params.OUT_FILE; // Output of \.{TANGLE}.
ini0_language(); // Set up parameters.

return language; // Return the input language.
}

@ The |set_output_file| routine doesn't open a file.  The following
function does, in response to a |begin_language| seen by |send_single|
during the output phase.

@<Part 2@>=@[

LANGUAGE opn_output_file FCN((language0))
    LANGUAGE language0 C1("")@;
{
set_output_file(language0);
flush_buffer();
open_out(OC(""), LOCAL_SCOPE);

return language;
}

@ Output files are opened only when necessary, during phase~2.

@d GLOBAL_SCOPE YES
@d LOCAL_SCOPE NO

@d CHECK_OPEN if(!out_file) open_out(OC(""), GLOBAL_SCOPE)

@<Part 1@>=@[

SRTN open_out FCN((msg,global_scope))
    CONST outer_char *msg C0("")@;
    boolean global_scope C1("")@;
{
boolean is_stdout = BOOLEAN(STRCMP(params.OUTPUT_FILE_NAME,"stdout") == 0);
boolean already_opened = NO;

if(is_stdout)
    out_file = params.OUT_FILE = stdout;
else
    {
    already_opened = was_opened(params.OUTPUT_FILE_NAME, global_scope,
                    NULL, &out_file);

    params.OUT_FILE = out_file; // Local output file.

/* Write header info to the newly opened file. (We don't write it for
|stdout|, because it clutters up the screen.) */
    if(top_version && !(already_opened || compare_outfiles))
        out_version(msg);
    }

/* The first time a file is opened for a particular language, its |FILE|
pointer must be made global so it can be restored at the beginning of each
module.  (The name was already made global in |common_init|.) */
if(global_scope)
    cur_global_params.OUT_FILE = global_params.OUT_FILE = out_file;

/* The first time a file is opened, write its name to the screen. */
if(!already_opened)
 {
 CLR_PRINTF(out_file,("(%s)%s",params.OUTPUT_FILE_NAME,is_stdout ? "\n" : ""));
 UPDATE_TERMINAL;
 }
}

@ Information about previously opened files is stored in a dynamically
allocated list.

@<Glob...@>=

EXTERN OPEN_FILE HUGE *open_file, HUGE *open_file_end, HUGE *last_file;
EXTERN BUF_SIZE num_files; // Allocated length of |open_file|.

@ A list of |open_files| needs to be in place before the command line is
scanned.  The initial allocation gets the default value.

@<Allocate initial tables@>=
{
ALLOC(OPEN_FILE,open_file,ABBREV(num_files),num_files,0);
last_file = open_file;
open_file_end = open_file + num_files;
}

@ After the command line has been scanned, we may want to reallocate this
table.

@<Allocate dyn...@>=
{
BUF_SIZE cur_num = last_file - open_file; // Current size of list.

/* Obtain the new allocation size. */
alloc((outer_char *)ABBREV(num_files),(BUF_SIZE HUGE *)&num_files,
    sizeof(*open_file),-1);

/* Reallocate and reset parameters. */
open_file = (OPEN_FILE *)REALLOC(open_file,num_files*sizeof(OPEN_FILE));
last_file = open_file + cur_num;
open_file_end = open_file + num_files;
}

@ Here we check if the output file about to be opened has already been
previously opened.  If not, we put it into the list.

The variable |pname| is used as a flag.  If it's |NULL|, the file is opened
if necessary.  Otherwise, a pointer to the previously allocated storage
area for the name is returned.

@<Part 1@>=@[

boolean was_opened FCN((file_name,global_scope,pname,pfile_ptr))
    CONST outer_char HUGE *file_name C0("")@;
    boolean global_scope C0("")@;
    outer_char HUGE * HUGE *pname C0("")@;
    FILE **pfile_ptr C1("")@;
{
OPEN_FILE HUGE *f;

if(!*file_name)
    { /* Take care of special cases called by |xpn_name|. */
    *pname = (outer_char HUGE *)"";
    *pfile_ptr = NULL;
    return NO;
    }

/* Is file already in the list of previously opened? */
for(f=open_file; f<last_file; f++)
    if(STRCMP(f->name,file_name)==0)
        {
        if(pname)
            { /* Just return (to |new_fname|) some information. */
            *pname = f->name;
            *pfile_ptr = f->ptr;
            return f->previously_opened;
            }
        else
            goto open_it;
        }

@<Add a new file to the list@>@;

if(pname)
    { /* File wasn't previously opened, and has now been added to list
of file names. */
    *pname = f->name;
    f->ptr = NULL;
    f->previously_opened = NO;
    f->global_scope = global_scope;
    }
else
    @<Possibly open the file@>@;

*pfile_ptr = f->ptr;
return f->previously_opened;
}

@
@<Add a new file...@>=
{
/* File not in list; is there room for more? */
if(last_file==open_file_end)
    {
    OVERFLW("previously opened files",ABBREV(num_files));
    }

last_file->name = GET_MEM("last_file",STRLEN(file_name)+1,outer_char);
STRCPY(last_file->name,file_name);
last_file++;
}

@ |f|~is now pointing to the proper entry in the list.  We're ready to open
the file.  If the file is already open, its file pointer is non-null, so we
do nothing except set the |previously_opened| flag.  (This might have
already been turned on when a file with local scope was closed.)  If it was
previously opened, but is now closed (|f->ptr == NULL|), we open it into
append mode.  Otherwise, it has never been opened and we must create a new
file name and open it into write mode.

@<Possibly open the file@>=
{
open_it:
  f->previously_opened = BOOLEAN(f->previously_opened || (f->ptr != NULL));

if(f->previously_opened)
    { /* It might have been once opened, but then closed. */
    if(f->ptr == NULL)
        f->ptr = FOPEN(compare_outfiles ? f->tmp_name : f->name, "a");
    }
else
    { /* File wasn't ever opened. */
    if(compare_outfiles)
        @<Actually write into a temporary file@>@;
    else
        f->ptr = FOPEN(f->name, "w");

    if(!(f->ptr))
        { /* Should upgrade this message. */
        FATAL("\n!! Can't open output file ", file_name);
        }
    }
}

@ We do the following when |compare_outfiles == YES|.

@<Actually write into a temp...@>=
{
char *buffer;
IN_COMMON outer_char wbprefix[MAX_FILE_NAME_LENGTH];

#if(HAVE_TEMPNAM)
    extern char *tempnam();

    if(!*wbprefix) STRCPY(wbprefix,"./");
    buffer = tempnam(wbprefix, "FTMP");
    // Non-|ANSI|, but more control over directory.
#else
    buffer = tmpnam(NULL); // |ANSI| routine.
#endif

f->tmp_name = GET_MEM("f->tmp_name",STRLEN(buffer)+1,outer_char);

STRCPY(f->tmp_name, buffer);

f->ptr = FOPEN(f->tmp_name, "w");
}

@ Here we  close a file in response to an \.{@@O} command.
@<Part 1@>=@[

SRTN close_out FCN((fp))
    FILE *fp C1("")@;
{
OPEN_FILE *f;

for(f=open_file; f<last_file; f++)
    if(f->ptr == fp)
        {
        close0(f);
        return;
        }

CONFUSION("close_out", "Allegedly open file isn't in list");
}

@ Files with local scope are closed at the end of a section.
@<Part 1@>=@[

SRTN cls_local(VOID)
{
OPEN_FILE *f;

for(f=open_file; f<last_file; f++)
    if(f->ptr && !f->global_scope)
        close0(f);
}

@ Here's a nucleus for closing output files.
@<Part 1@>=@[
SRTN close0 FCN((f))
    OPEN_FILE *f C1("")@;
{
fclose(f->ptr);
f->ptr = NULL;
f->previously_opened = YES;
}

@ Here we go through the list of all potentially open files.  If it's open,
we compare the temporary file that was just written with what already
exists on disk.  If they're the same, the old one is kept; otherwise, the
temporary file is made the new one.

@<Part 1@>=@[
SRTN cmp_outfiles(VOID)
{
OPEN_FILE *f;
boolean renamed = NO;

printf("\nRenaming temporary file(s):  ");
UPDATE_TERMINAL;

for(f=open_file; f<last_file; f++)
    if(f->previously_opened || f->ptr)
        {
        FILE *old_ptr = FOPEN(f->name, "r");

        if(f->ptr)
            fflush(f->ptr);

        if(old_ptr)
            @<Compare file contents@>@;
        else
            @<Rename the temporary file@>@; // No old file at all.
        }

if(!renamed)
    printf("[no changes]");
}

@ The following code is patterned after \.{nuweb}'s.  It compares the
contents of the new, temporary file and the old one.  If they're the same,
the temporary file is deleted; otherwise, it overwrites the old file.

@<Compare file contents@>=
{
int c_old, c_new;
FILE *new_ptr;

if(f->ptr)
    new_ptr = freopen((CONST char *)f->tmp_name, "r", f->ptr);
else
    new_ptr = FOPEN(f->tmp_name, "r");

if(!new_ptr)
    FATAL("\n!! Can't reopen temporary file ", f->tmp_name);

do
    {
    c_old = getc(old_ptr);
    c_new = getc(new_ptr);
    }
while(c_old == c_new && c_old != EOF);

fclose(old_ptr);
fclose(new_ptr);

if(c_old == c_new)
    remove((CONST char *)f->tmp_name); // Harmless if this doesn't work.
else
    @<Rename the temporary file@>@;
}

@ Since the behavior of |rename| is implementation-defined if the new file
exists, we explicitly remove it first.

@<Rename the temporary file@>=
{
/* Try to ensure that the following |rename| will succeed. */
remove((CONST char *)f->name);

printf("(%s",f->name); // Echo to terminal.

if(rename((CONST char *)f->tmp_name, (CONST char *)f->name) != 0)
    { /* Rename didn't work.  Attempt to force the rename by issuing a
\.{mv} command.  The actual name of the command is obtained from the
preprocessor variable |MV|, which is defined on the command line and whose
value is ultimately defined in \.{defaults.mk}. */
#if ANSI_SYSTEM
    if(!system(NULL))
        { /* No command processor! */
        err_print(T,
"Couldn't rename \"%s\" to \"%s\"", f->tmp_name, f->name);
        perror("");
        }
    else
#endif // |ANSI_SYSTEM|
        {
        char temp[256];

/* We put the following here in case for some reason the make file can't
define |MV|.  This is the case with some versions of \.{nmake} on the PC. */
#ifndef MV
    #ifdef ibmpc
        #define MV rename
    #else
        #define MV mv
    #endif
#endif
        sprintf(temp, "%s %s %s", MV, f->tmp_name, f->name);
        system(temp);
        printf("*"); // Indicate a copy was done.
        }
    }

printf(")"); UPDATE_TERMINAL;

renamed = YES;
}

@ Here is a short-hand routine that expands the string equivalent of tokens
like |slash_slash| to the output.

@d OUT_OP(s) out_op(OC(s))
@d OUT_STR(s) out_str(OC(s))

@<Part 1@>=@[

SRTN out_op FCN((s))
    CONST outer_char HUGE *s C1("String to translate.")@;
{
out_str(s);

out_state = MISCELLANEOUS;
}

SRTN out_str FCN((s))
    CONST outer_char HUGE *s C1("")@;
{
while(*s)
    C_putc(*s++);
}

@ Here we translate internal code to their external representations.

@d F_OP(op77,op88) (Fortran88 ? op88 : op77)

@<Cases like \.{!=}@>=

case plus_plus:
    if(FORTRAN_LIKE(language))
        {
        @<Output `\.=' and left-hand side@>;
        buffer_out('+'); @+ buffer_out('1');
        out_state = MISCELLANEOUS;
        }
    else
        {
        if(*(pC_buffer-1) == '+' && !nuweb_mode)
            C_putc(' '); // Watch out for |x + ++y|.
        OUT_OP("++");
        }

    @<Mark split...@>@;
    break;

case minus_minus:
    if(FORTRAN_LIKE(language))
        {
        @<Output `\.=' and left-hand side@>;
        buffer_out('-'); @+ buffer_out('1');
        out_state = MISCELLANEOUS;
        }
    else
        {
        if(*(pC_buffer-1) == '-' && !nuweb_mode)
            C_putc(' '); // Watch out for |x - --y|.
        OUT_OP("--");
        }

    @<Mark split...@>@;
    break;

case minus_gt: OUT_OP(FORTRAN_LIKE(language) ? ".EQV." : "->"); @+ break;

case gt_gt:
    @<Mark split...@>@;
     OUT_OP(">>"); @+ break;

case eq_eq:
    @<Mark split...@>@;
    OUT_OP(R77_or_F ? F_OP(".EQ.","==") : "=="); @+ break;

case lt_lt:
    @<Mark split...@>@;
    OUT_OP("<<"); @+ break;

case @'>':
    if(in_string)
        out_dflt(cur_char);
    else
        OUT_OP(R77_or_F ? F_OP(".GT.",">") : ">");

    @<Mark split...@>@;
    break;

case gt_eq:
    OUT_OP(R77_or_F ? F_OP(".GE.",">=") : ">=");
    @<Mark split...@>@;
    break;

case @'<':
    if(in_string)
        out_dflt(cur_char);
    else
        OUT_OP(R77_or_F ? F_OP(".LT.","<") : "<");

    @<Mark split...@>@;
    break;

case lt_eq:
    OUT_OP(R77_or_F ? F_OP(".LE.","<=") : "<=");
    @<Mark split...@>@;
    break;

case not_eq:
    OUT_OP(R77_or_F ? F_OP(".NE.","<>") : "!=");
    @<Mark split...@>@;
    break;

case and_and:
    OUT_OP(R77_or_F ? ".AND." : "&&");
    @<Mark split...@>@;
    break;

case or_or:
    if(language==TEX) meta_mode = YES;
    else
        {
        OUT_OP(R77_or_F ? ".OR." : "||");
        @<Mark split...@>@;
        }
    break;

case star_star:
    if(language==TEX) meta_mode = NO;
    else OUT_OP(C_LIKE(language) ? "^^" : "**");
    break;

case @'!':
    @<Mark split...@>@;
    if(in_string)
        return out_dflt(cur_char);
    else
        OUT_OP(R77_or_F ? ".NOT." : "!");
    break;

case slash_slash: OUT_OP("//"); @+ break;

case colon_colon:
    if(in_string)
        return out_dflt(cur_char);
    else
        OUT_OP("::");
    break;

case ellipsis:
    OUT_OP(FORTRAN_LIKE(language) ? ".NEQV." : "...");
    @<Mark split...@>@;
    break;

case paste: OUT_OP("##"); @+ break;

case dot_const:
    C_putc('.');
    STRCPY(dot_op.name+1,dots[cur_val].symbol);
    to_outer(dot_op.name+1);
    OUT_OP(OC(dot_op.name+1));
    C_putc('.');
    break;

@ Here we endow \Ratfor-77 with C's ability to handle powerful assignment
operators. Expressions like |i *= expr| get translated into |i = i*(expr)|.
@<Cases like \.{+=}@>=
case @'+':
case @'-':
case @'*':
case @'/':
/* These operators are handled in \Tangle\ as two adjacent tokens; we have
to check for that, and we dare not be in |VERBATIM| mode. */
    if(!FORTRAN_LIKE(language) ||
            cur_byte == cur_end || *cur_byte != @'=' ||
            out_state == VERBATIM || !xpn_Ratfor)
        {
        if(cur_char==@'*' && C_LIKE(language) && out_state != VERBATIM
                && *(pC_buffer-1) == '/' && !nuweb_mode)
            C_putc(' '); // Watch out for |x/ *p|; not a comment.
        @<Mark split...@>@;
        return out_dflt(cur_char);
        }

    cur_byte++; /* Skip over the `\.='. */
    @<Output `\.=' and left-hand side@>;
    out_dflt(cur_char);
    C_putc('(');
    send_rp = YES; /* The enclosing right paren will be output when the
next newline is encountered. */
    break;

@ This fragment is used both above and for the |++| and |--|~operators.
@<Output `\.=' and left-hand side@>=
@{
outer_char HUGE *l;

@b
/* The left-hand side has already been output. */
buffer_out('=');
out_state = MISCELLANEOUS;

/* Now output the |i|~in the above
example again; however, in general, that could be subscripted etc. */
if(compound_assignments)
    {
    if(last_xpr_overflowed)
        OVERFLW("last expression",ABBREV(max_expr_chars));

    for(l=last_char; isdigit(*l) || !isalpha(*l); l++)
        ;

    if(plast_char - l >= 3 && STRNCMP(last_char, "if(", 3) == 0)
        ERR_PRINT(T, "Sorry, can't expand compound assignment \
operators correctly after simple IF; use an IF...THEN construction");

    while(l < plast_char)
        buffer_out(*l++);
    }
else FATAL("!! Operators ++, --, +=, -=, *=, and /= are not allowed; \
they were turned off by option \"-+\".","");
}

@ This important fragment translates the internal code for an identifier
into the actual name. Macro expansion and \Ratfor\ token translation is
done here.
@<Case of an identifier@>=
case end_format_stmt:
    in_format = NO;
    C_putc(';');
    out_state = NUM_OR_ID;
    break;

case begin_format_stmt:
    in_format = YES;
    OUT_OP(" format");
    out_state = MISCELLANEOUS;
    break;

case identifier:
    cur_char = x_identifier(cur_char);
    break;


@ This routine was inserted to attempt to cut down the function length.
@<Part 1@>=@[

eight_bits x_identifier FCN((cur_char))
    eight_bits cur_char C1("")@;
{
@<Possibly expand special keyword@>;

if(is_deferred((sixteen_bits)cur_val)) return cur_char;

/* |MAC_LOOKUP| determines whether this is a WEB macro. Eventually, this
routine will be called recursively to output the expansion. The |in_macro|
flag prevents us from checking the expanded tokens again, since everything
will already have been expanded. */
  if(!mac_protected && (macro_text=MAC_LOOKUP(cur_val)) != NULL)
    {
    @<Output a macro expansion@>@;
    return cur_char;
    }
else
    { /* Not a macro. */
    @<Mark split...@>@;
    if (out_state==NUM_OR_ID && !nuweb_mode)
        C_putc(' ');

    @<Output a possibly truncated identifier@>;

    if(no_expand)
        no_expand = mac_protected = NO;
    }

end_identifier:
  out_state = in_format ? MISCELLANEOUS : NUM_OR_ID;

return cur_char;
}

@ It is easy to check whether an identifier is a deferred macro, because
the |macro_type| field was set when the deferred macro was stored in the
deferred pool.  If it is, the macro definition is executed and the macro is
now recorded as a regular (immediate) one.

@<Part 1@>=@[

boolean is_deferred FCN((cur_val))
    sixteen_bits cur_val C1("")@;
{
name_pointer np;

np = name_dir + cur_val;

if(np->macro_type == DEFERRED_MACRO)
    {
    text_pointer tp;
    eight_bits HUGE *p0;
    eight_bits a0;

    tp = (text_pointer)np->equiv; /* Position in the deferred pool. */

/* Copy the tokens of the definition over into the next text. */
    for(p0=tp->tok_start; p0 < (tp+1)->tok_start; )
        if(TOKEN1(a0= *p0++))
            if(a0 == @'#')
                   switch(*p0)
                {
                case @'!':
                    if(*(p0+1) == MACRO_ARGUMENT)
                        app_repl(a0)@;
                else @<Copy but don't expand deferred macro@>@;
                break;

                default:
                    app_repl(a0);
                    break;
                }
            else app_repl(a0)@; /* Single token, not special. */
        else
            {
            app_repl(a0);
            app_repl(*p0++);
            }

    cur_text = text_ptr;
    cur_text->Language = (boolean)language;
    cur_text->nargs = tp->nargs;
    cur_text->moffset = tp->moffset;
    cur_text->var_args = tp->var_args;
    cur_text->recursive = NO;
    cur_text->text_link = macro;

    (++text_ptr)->tok_start = tok_ptr;

    np = name_dir + IDENTIFIER(tp->tok_start[0],tp->tok_start[1]);
    np->macro_type = IMMEDIATE_MACRO; // Now the defn's been executed.
    np->equiv = (EQUIV)cur_text;

    return YES; // It's a deferred macro.
    }

return NO; // Not a deferred macro.
}

@
@<Copy but don't expand deferred macro@>=
{
if(TOKEN1(*++p0)) MACRO_ERR("! Macro token `#!' must be followed by \
identifier",YES);
else
    {
    text_pointer m;

    if( (m=MAC_LOOKUP(IDENTIFIER(*p0,*(p0+1)))) == NULL)
        MACRO_ERR("! Expecting macro identifier after \"#!\"",YES);
    else
        if(m->nargs > 0)
            MACRO_ERR("! Macro after \"#!\" can't have arguments",
                YES);
        else @<Copy tokens of macro@>@;

    p0 += 2;
    }
}

@
@<Unused@>=
{
SPEC *s;

for(s=spec_tokens; s->len != 0; s++)
    if(cur_val == *s->pid && s->expand != NULL)
        {
        boolean in_macro0 = in_macro;

        in_macro = NO; /* Don't suppress recursive expansion of
macros. */
        (*s->expand)();
        in_macro = in_macro0;

        goto end_identifier;
        }
}

@ Expand a \Ratfor\ token if necessary.

@<Possibly expand spec...@>=
{
boolean in_macro0 = in_macro;
name_pointer np = name_dir + cur_val;
X_FCN (HUGE_FCN_PTR *pf)(VOID); /* The function associated with expandable
                    keywords. */

if(np->expandable & language)
    {
expand_special:
    in_macro = NO; /* Don't suppress recursive expansion of macros. */

    pf = np->x_translate[lan_num(language)];

    if(pf) (*pf)(); // Expand keyword.
    else CONFUSION("possibly expand special",
        "Allegedly expandable keyword has no associated function");

    in_macro = in_macro0;

    cur_char = id_keyword; /* Helps \Ratfor\ know what happened. */
    goto end_identifier;
    }
else if(R77 && Fortran88 && !checking_label)
    switch(chk_lbl())
        {
       case YES: goto expand_special;
          case -1:  goto end_identifier;
       case NO: break;
        }
}

@ At this point in the output routine, we have identified an identifier as
a macro. Expand it, and output it recursively.
@<Output a macro exp...@>=
@{
eight_bits HUGE *p1;

@b
in_macro = YES; /* Used as a flag to prevent |MAC_LOOKUP| on
    recursive |out_char| output of the final translated macro. */

p1 = xmacro(macro_text,&cur_byte,cur_end,macrobuf); /* Expand this
    macro into the macro buffer. The final expansion will begin at |p1|
    and end at~|mp|. */

/* Output final translated text, which begins at the end~|p1| of the last
translation and ends at the current value of~|mp|. This calls |out_char|
recursively.  */
copy_out(p1,mp,macro);
in_macro = NO;
}

@ We want the speediest possible output routine, so we bypass extra stuff
if no variables were truncated.
@<Output a poss...@>=
@{
name_pointer np;

@b
np = name_dir + cur_val;

if(truncate_ids)
    out_trunc(np);
else
    see_id(np->byte_start,(np+1)->byte_start);
}

@ Interface to \.{rat77.web}.
@<Part 1@>=@[

SRTN out_ptrunc FCN((cur_val))
    sixteen_bits cur_val C1("")@;
{
@<Output a poss...@>@;
}

@ Write out an identifier, translating from internal |ASCII|.
@<Part 1@>=@[

SRTN see_id FCN((start,end))
    CONST ASCII HUGE *start C0("Beginning of identifier name.")@;
    CONST ASCII HUGE *end C1("End of identifier name.")@;
{
CONST ASCII HUGE *j;

for (j=start; j<end; j++) C_putc(XCHR(*j));
}

@ Print the $n$-th~identifier for debugging purposes. Call this routine
from the debugger.
@<Part 1@>=@[

int id FCN((n))
    int n C1("Identifier number.")@;
{
printf(_Xx("Id %d (0x%x): \"%s\"\n"),n,n,name_of((sixteen_bits)n));
return n;
}

@ This function translates internal text to the outer world, possibly
truncating it.

@<Part 1@>=@[

outer_char HUGE *name_of FCN((id0))
    sixteen_bits id0 C1("Identifier token whose name is sought.")@;
{
static ASCII temp[MAX_ID_LENGTH];
int k,n;
name_pointer np;
CONST ASCII HUGE *end;

np = name_dir + id0;

/* Don't choke on bad id. */
if(np >= name_ptr)
    {
    STRCPY(temp,"???");
    return (outer_char HUGE *)temp;
    }

PROPER_END(end);

#if 0 /* This construction gives a compiler error on the IBM/6000. */
n = MIN(end - np->byte_start,MAX_ID_LENGTH-1);
#else
if(end - np->byte_start < MAX_ID_LENGTH - 1)
    n = end - np->byte_start;
else
    n = MAX_ID_LENGTH - 1;
#endif

STRNCPY(temp,np->byte_start,n);

/* We must be careful when breakpointing; backslashes must be escaped. */
if(breakpoints)
   for(k=0; k<n; k++)
    if(temp[k] == @'\\') temp[k] = @'/';

temp[n] = '\0';

return to_outer(temp);
}

@ Spit out a possibly truncated identifier.

@<Part 1@>=@[

CONST ASCII HUGE *proper_end FCN((np))
    name_pointer np C1("")@;
{
CONST ASCII HUGE *end;

PROPER_END(end);
return end;
}

SRTN out_trunc FCN((np))
    CONST name_pointer np C1("")@;
{
TRUNC HUGE *s;
ASCII HUGE *pc;

pc = np->byte_start;

if(*pc != BP_MARKER)
        { /* Not truncated. */
        CONST ASCII HUGE *end;

/* If the next one was truncated, recover the proper end location. */
        PROPER_END(end);
        see_id((CONST ASCII HUGE *)pc,end);
        }
    else
        { /* Truncated. */
        s = ((BP HUGE *)pc)->Root;
        see_id(s->id,s->id_end);
        }
}

@ Every time the line number is printed, it's remembered to help out with
error messages.
@<Glob...@>=

EXTERN LINE_NUMBER nearest_line SET(0);

@ Here we write out the module number info. If |cur_val > 0|, we're
beginning a module; if |cur_val < 0|, we're ending a module; if it's zero,
we print out the line number. The |line_info| flag kills off the output of
this information (although presently the information is still retained in
the file).

@<Case of a mod...@>=

case module_number:
    if (cur_val > 0) prn_mod_num(OC("%c* %ld: *%c"),cur_val); // Beginning.
    else if(cur_val < 0) prn_mod_num(OC("%c* :%ld *%c"),cur_val); // End.
    else
        {// Print out the line number; remember it for error messages.
        if(line_info)
            {
            nearest_line = BASE2* (*cur_byte++);
            nearest_line += *cur_byte++; // Gets the line number.

                C_sprintf(OC("\n%cline %u \""),2,
                language==TEX ? '%' : '#',nearest_line);

/* Get pointer to file name. */
                cur_val = BASE2* (*cur_byte++);
            cur_val += *cur_byte++;

            @<Output a possibly truncated identifier@>@;
            C_sprintf(OC("\"\n"),0);
            }

@%        C_sprintf(OC("\n"),0);
        }

    break;

@ The following function writes to the output file a comment about
beginning or ending a section (distinguished by the sign of~|cur_val|).
@<Part 1@>=@[

SRTN prn_mod_num FCN((fmt,val))
    outer_char *fmt C0("")@;
    long val C1("")@;
{
int l;

if(line_info)
    {
    l = lan_num(R77_or_F && !free_90 ? FORTRAN : language);

    if(val < 0)
        { /* Ending a section. */
        val = -val;
@%        C_putc('\n');
        }

    if(FORTRAN_LIKE(language))
        {
        if(out_pos > rst_pos) flush_out(YES);
        out_pos = 0;
        }

    C_sprintf(fmt,3,begin_comment_char[l],val,end_comment_char[l]);
    }
@#if 0
    switch(language)
        {
        case C:
        case C_PLUS_PLUS:
        case TEX:
        case LITERAL:
         C_sprintf(fmt,3,
            begin_comment_char[l],val,end_comment_char[l]);
        break;

        case RATFOR:
        case RATFOR_90:
        case FORTRAN:
        case FORTRAN_90:
        CHECK_OPEN;
        fprintf(out_file,fmt,
            begin_comment_char[l],val,end_comment_char[l]);
        break;

        default:
        ;
        }
@#endif
}

@* INTRODUCTION to the INPUT PHASE.  We have now seen that \.{TANGLE} will
be able to output the full \cee\ program, if we can only get that program
into the byte memory in the proper format. The input process is something
like the output process in reverse, since we compress the text as we read
it in and we expand it as we write it out.

There are three main input routines. The most interesting is |get_next|,
which gets the next token of a code text; the other two are used to scan
rapidly past \TeX\ text in the \.{WEB} source code. |skip_ahead| will jump
to the next token that starts with `\.{@@}'; |skip_comment| skips to the
end of a comment.

@i t_codes.hweb

@<Global...@>=

IN_STYLE eight_bits ccode[128]; // Meaning of a char following '\.{@@}'.

@  The control codes are assigned in \.{style.web}.

@m TANGLE_ONLY(d,c) INI_CCODE(d,c)
@m WEAVE_ONLY(d,c) INI_CCODE(d,USED_BY_OTHER)

@<Set ini...@>=

zero_ccodes(); /* See \.{style.web}. */
ccode[@'/'] = begin_vcmnt; /* The commenting style is also fundamental, and
    for convenience the |line_break| command is also inviolate. (For
    \FTANGLE, this gets reassigned later.) */

@<Set the changable codes@>@;
@<Reassign certain codes for \FTANGLE@>@;
prn_codes();

@ Here are the default values for the things that are allowed to be
changed. Codes that are used only by
\FWEAVE\ get the special code~|ignore|; these are just skipped.  Codes
that are used by neither processor are initialized to~|'0xFF'|; that can be
used to trigger an error message.
Those things that must be reassigned for \FTANGLE\ are here
assigned the code for \FWEAVE; they're changed later by the |reassign|
function.
@<Set the changable...@>=
{
SAME_CCODE(" \t*",new_module);

SAME_CCODE("aA",begin_code);
SAME_CCODE("<",module_name);

SAME_CCODE("dD",definition);
SAME_CCODE("uU",undefinition);
SAME_CCODE("mM",WEB_definition);
SAME_CCODE("fF",formatt);

SAME_CCODE("'\"",ascii_constant);
REASSIGNABLE("=",verbatim);

REASSIGNABLE("tT",TeX_string);

SAME_CCODE("L",L_switch);
SAME_CCODE("cC",begin_C);
SAME_CCODE("rR",begin_RATFOR);
SAME_CCODE("n",begin_FORTRAN);
SAME_CCODE("N",begin_nuweb);

SAME_CCODE("&",join);

SAME_CCODE("?",Compiler_Directive);
SAME_CCODE("%",invisible_cmnt);

/* The next three must be reassigned to |control_text|. */
REASSIGNABLE("^",xref_roman);
REASSIGNABLE(".",xref_typewriter);
REASSIGNABLE("9",xref_wildcard);

SAME_CCODE("#",big_line_break);

SAME_CCODE("(",begin_meta);
SAME_CCODE(")",end_meta);

SAME_CCODE("l",limbo_text);
SAME_CCODE("vV",op_def);
SAME_CCODE("wW",macro_def);

TANGLE_ONLY("{",begin_bp);
TANGLE_ONLY("}bB",insert_bp);

TANGLE_ONLY("!",no_mac_expand);

SAME_CCODE("oO",new_output_file);

WEAVE_ONLY("\001",toggle_output); // This command is for internal use only!
WEAVE_ONLY("\\",force_line);
WEAVE_ONLY("_",underline);
WEAVE_ONLY("[",defd_at);
WEAVE_ONLY("`]",implicit_reserved);
WEAVE_ONLY("$",switch_math_flag);
{
char temp[3];

sprintf(temp,";%c",XCHR(interior_semi));
WEAVE_ONLY(temp,pseudo_semi);
}
WEAVE_ONLY("e",pseudo_expr);
WEAVE_ONLY(":",pseudo_colon);
WEAVE_ONLY(",",thin_space);
WEAVE_ONLY("|",math_break);
WEAVE_ONLY("+",no_line_break);
WEAVE_ONLY("-",no_index);
WEAVE_ONLY("~",yes_index);
#if(DEBUG)
    WEAVE_ONLY("012",trace);
#endif /* |DEBUG| */
}

@ For \FTANGLE, certain codes must be reassigned (after they've possibly
been overridden by the style file).
@<Reassign...@>=
{
reassign(xref_roman,control_text);
reassign(xref_typewriter,control_text);
reassign(xref_wildcard,control_text);
reassign(TeX_string,control_text);

reassign(verbatim,stringg);
}

@ The |skip_ahead| procedure reads through the input at fairly high speed
until finding the next non-ignorable control code, which it returns.  There
is one special nuance. We don't want to process a language change between
vertical bars. Since during the high-speed scan we don't keep track of
balanced bars, we assume that the combination of bar followed by possible
spaces followed by a language command means the start of a barred section,
and we skip over the language command in that case.

@d MAYBE_SET_OUTPUT(l) if(last_char != @'|') set_output_file(l)

@<Part 1@>=@[

eight_bits skip_ahead FCN((last_control,skip_over_bars))
    eight_bits last_control C0("Last token that was seen.")@;
    boolean skip_over_bars C1("")@;
{
eight_bits cc; // Control code found.
int ncc = 0; /* A counter that counts the \.{@@}s;
        used to figure out whether to ignore section
        names immediately after \.{@@f}. */
ASCII last_char;
ASCII HUGE *lc;
ASCII HUGE *l1 = limit + 1;

WHILE()
    {
    if (loc>limit)
        {
another_line:
        if(from_buffer)
            {
            undivert(); // Switch back to reading from files.
            return ignore;
            }
        else
            {
            if(!get_line())
                return new_module;

            l1 = limit + 1;
            }
        }

    *l1 = @'@@'; // Barrier to stop high-speed scan through line.

more_stuff:
    switch(*loc)
        {
       case @'@@':
        break;

       case @'|':
        if(skip_over_bars)
            {
            if(skip_bars() == new_module) return new_module;
/* It's now positioned after the bar. */
            continue;
            }

/* Otherwise, we're in limbo or scanning control text; just keep going. */

       default:
        loc++;
        if(loc > limit)
            {
            ncc = 2;
            goto another_line;
            }
        goto more_stuff;
        }

    *l1 = @' '; // Reset line terminator.

    if(loc > limit) ncc = 2;
    else @<Return the next non-ignorable control code@>@;
    }

DUMMY_RETURN(ignore);
}

@
@<Part 1@>=@[

eight_bits skip_bars(VOID)
{
PARAMS params0;
LANGUAGE language0 = language;
eight_bits ret_val;

params0 = params; // Save state.

loc++; // Advance past the opening bar.

WHILE()
    {
    if(loc > limit && !get_line())
        {
        err_print(W,"Reached end of file while skipping code text %s",
            BTRANS);
        ret_val = new_module;
        goto done;
        }

    switch(next_control=get_next())
        {
       case begin_bp:
       case insert_bp:
       case begin_meta:
       case end_meta:
       case formatt:
       case limbo_text:
       case op_def:
       case macro_def:
       case definition:
       case undefinition:
       case WEB_definition:
       case m_ifdef:
       case m_ifndef:
       case m_else:
       case m_elif:
       case m_endif:
       case m_for:
       case m_endfor:
       case m_pragma:
       case m_undef:
       case begin_code:
        err_print(T,"Control code not allowed within |...|; \
inserted '|' in %s", MTRANS);
        loc -= 2;
        ret_val = @'|';
        goto done;

       case new_module:
        err_print(T,"Module%s ended while skipping code text; \
inserted '|'", MTRANS0); // Falls through to next case!

       case @'|':
        ret_val = next_control;
        goto done;
        }
    }

done:
  params = params0;
  frz_params();
  set_output_file(language0);

return ret_val;
}

@ We get to here while skipping through a line at high speed.
@<Return the next non-ignorable...@>=
{
last_char = @' '; // Get the last non-blank character before this control code.

for(lc=loc-1; lc>=cur_buffer; lc--)
    if(*lc != @' ')
        {
        last_char = *lc; // This might be a vertical bar.
        break;
        }

++loc; // Position to after the~\.{@@}.
++ncc; // Count the \.{@@}s.

switch(cc=ccode[*(loc++)])
    { /* Position to after \.{@@?}. */
   @<Specific language cases@>:
    loc--; /* Position to language letter; fall through. */

   case L_switch:
    {
    if(last_char != @'|')
        {
        @<Set |language|@>@;
        if(module_count == 0) global_params = params;
        set_output_file(language);
        }
    continue;
    }

   case begin_nuweb:
    nuweb_mode1 = nuweb_mode = !NUWEB_MODE;
    if(module_count == 0) global_params = params;
    continue;

   case control_text:
    while ((c=skip_ahead(ignore,NO))==@'@@');
      /* only \.{@@@@} and \.{@@>} are expected */ /* Is |c| used?? */

      if (*(loc-1)!=@'>') ERR_PRINT(T,"Improper @@ within control text");
@.Improper \AT! within control text@>
    continue;

   case compiler_directive:
   case Compiler_Directive:
    if(scanning_TeX)
        ERR_PRINT(T,"Compiler directives are allowed only in code");
    loc = limit + 1;
    continue;

   case invisible_cmnt:
    loc = limit + 1;
    continue;

   case module_name:
    if(ncc==1 && last_control==formatt)
        {
        loc -= 2;
        get_next(); // Scan module name to get it into table.
        continue;
        }
    break;

   case big_line_break: /* \.{@@\#} */
    if(loc >= limit) continue;

    @<Process possible preprocessor command@>; // (See \.{typedefs.web}.)
    continue;

   case USED_BY_NEITHER:
    err_print(T,"Invalid `@@%c' ignored",XCHR(*(loc-1)));
    continue;
    }

if (cc!=ignore || (*(loc-1)==@'>' && (ncc!=2) && last_control != formatt) )
    return cc; // \.{@@}~code or end of module name.
}

@ The |skip_comment| procedure reads through the input at somewhat high
speed until finding the end-comment token~`\.{*/}' or a new-line, in which
case |skip_comment| will be called again by |get_next|, since the comment
is not finished.  This is done so that the each newline in the code part of
a module is copied to the output; otherwise the \&{\#line} commands
inserted into the output file by the output routines become useless.  If it
comes to the end of the module it prints an error message.

@<Global...@>=

EXTERN boolean comment_continues SET(NO); // Are we scanning a comment?

@ Skip over comments.
@<Part 2@>=@[

boolean skip_comment(VOID)
{
ASCII c; /* current character */
PARSING_MODE outer_mode;

outer_mode = parsing_mode;
parsing_mode = OUTER;

if(comment_continues) loc--; /* We've already scanned over white space, so
  |loc| is presently one position beyond the first non-blank character on the
  continuation line. */
else if(*(loc-1) == @'/') loc++; /* If we're starting a comment, |loc|~is
  positioned on the star; move past that. */

WHILE()
    {
    if (loc>limit)
       if(!long_comment) @<Finish skipping comment and |break|@>@;
       else if(get_line())
        {
        comment_continues = YES;
        break;
        }
          else
        {
            err_print(T,"Input ended in middle of comment %s", BTRANS);
@.Input ended in mid-comment@>
        comment_continues=NO;
        break;  /* We |break| out and return so |get_next| can
return a newline. */
        }

    c = *(loc++);

    if (c==@'*' && *loc==@'/')
    {
    loc++;
    @<Finish skipping comment...@>@;
    }

    if (c==@'@@')
    {
          if (ccode[*loc]==new_module) /* `\.{@@\ }' or `\.{@@*}' */
         {
            err_print(T,"Section name ended in middle of comment %s",
            BTRANS);
        loc--;
@.Section name ended in mid-comment@>
        @<Finish skipping comment...@>@;
          }
          else loc++;
     }
    }

parsing_mode = outer_mode;
return comment_continues;
}

@ Ending the skip over comments is simple:
@<Finish skipping comment...@>=
{
comment_continues = NO;
break;
}

@* INPUTTING the NEXT TOKEN.

@<Global...@>=

EXTERN name_pointer cur_module SET(NULL); /* name of module just scanned */
EXTERN ASCII c; /* the current character for |get_next| */
EXTERN boolean strt_cmnt;
EXTERN boolean strt_point_cmnt;
EXTERN boolean suppress_newline; // For scanning past invisible comments.
EXTERN boolean eat_blank_lines; // For `\.{@@\%\%}'.
EXTERN boolean no_expand SET(NO); // For use with `\.{@@\~}.

@ As one might expect, |get_next| consists mostly of a big switch that
branches to the various special cases that can arise.  This function has
been broken into several function calls in order to fit it into personal
computers.

When we return to token we obtained, we also store it using the |RETURN|
macro; this sometimes helps us parse the next object.

@d RETURN(pcode) return (eight_bits)pcode@;

@<Part 2@>=@[

eight_bits get_next(VOID) /* produces the next input token */
{
GOTO_CODE pcode; // Return code from the parse routines.

strt_point_cmnt = suppress_newline = NO;

WHILE()
    {
    @<Check if we're at the id part of a preprocessor command@>;
    @<Check if we're at the end of a preprocessor command@>;

    if (loc>limit)
    if(from_buffer)
        {
        undivert(); /* Stop reading from buffer; go back to
                reading from files. */
        if(stop_the_scan)
            return WEB_definition;
        continue;
        }
    else
        { /* Reading from file. */
          if (preprocessing && *(limit-1)!=cont_char)
            {
            preprocessing = NO;
            if(in_cdir)
                {
                id_first = id_loc = mod_text + 1;
                *id_loc++ = cdir;
                *id_loc++ = '\0';
                in_cdir = NO;
                return stringg;
                }
            }
        if(stop_the_scan)
            return WEB_definition;
          else if(!get_line())
            return new_module;

        if(eat_blank_lines)
            {
            eat_blank_lines = NO;

            while(loc >= limit)
                if(!get_line())
                    return new_module;
            }

        at_beginning = BOOLEAN(!preprocessing);

          if(prn_where)
            {
                prn_where=NO;

                if(!scanning_defn)
                @<Insert the line number into |tok_mem|@>;
                }
            else if(!suppress_newline &&
            (!R77_or_F || limit==cur_buffer || free_Fortran))
                 return @'\n';
        }
    else at_beginning = BOOLEAN(!preprocessing && (loc == cur_buffer));

if(preprocessing)
    @<Compress string of blanks into one; if any found, return a space@>@;
else
    @<Skip white space at beginning of line@>@;

strt_cmnt = NO;

switch(language)
    {
   case TEX:
    if(!scanning_defn)
        {
        if((pcode=prs_TeX_code()) == MORE_PARSE)
            break;
        else if(pcode < 0)
            CONFUSION("prs_TEX_code","Negative pcode");
        else
            RETURN(pcode);
        }

   default:
    if((pcode=prs_regular_code(MORE_PARSE)) == MORE_PARSE)
        break;
    else if((int)pcode < 0)
        CONFUSION("prs_regular_code","Negative pcode");
    else
        RETURN(pcode);
    }
   }

DUMMY_RETURN(ignore);
}

@ Since the preprocessor has different reserved words than C~itself, we
include the preprocessor token with the identifier if it's first on a
preprocessor line.

@<Check if we're at the id...@>=

if(preprocessing && at_beginning)
    {
    at_beginning = NO;

/* Preprocessor directives can have white space between the '\.\#' and the
name. */
    for( ; loc < limit; loc++)
        if(!(*loc==@' ' || *loc==tab_mark)) break;

    *(loc-1) = @'#'; /* Now we're positioned on an identifier beginning
with |'#'|, with no intervening blanks. */
    return (eight_bits)prs_regular_code(GOTO_GET_IDENTIFIER);
    }

@ When we get to the end of a preprocessor line, we lower the flag and send
a code \\{right\_preproc}, unless the last character was the continuation
character'~\.\\'.

@<Check if we're at the end...@>=

  if(*loc==cont_char && loc==limit-1 && (preprocessing || free_Fortran))
    {
    loc += 2; /* Force it to read another line the next time through. */
    return (eight_bits)CHOICE(free_Fortran, @'&', cont_char); /* We
leave the format of the input file alone. Since we're using free-form
syntax, the compiler will continue the line correctly. */
    }

@ Here we are inside a C preprocessing statement.  A run of white space is
compressed into one blank.

@<Compress string of blanks...@>=
{
boolean found_white_space = NO;

    do
        {
        if((c=*loc++) != @' ' || c != tab_mark)
            break;

        found_white_space = YES;
        }
    while(loc < limit);

@#if(0)
    if(c==cont_char && loc==limit)
        if(!get_line())
            return new_module;
        else
            goto compress_blanks;
@#endif

if(found_white_space)
    return @' ';
}

@ Normally, white space at the beginning of line isn't significant---even
if the line ultimately starts with a preprocessor command.  Two exceptions
are \TeX\ mode and nuweb mode, since blanks or tabs could be significant
then.  However, in nuweb mode, white space in front of preprocessor
commands should be ignored.

@<Skip white space at beg...@>=
{
if(language==TEX)
    c = *loc++;
else
    {
    ASCII HUGE *loc0 = loc; // Remember starting point for nuweb mode.

    do
        { /* Skip beginning white space. */
        c = *loc++;
        }
    while(loc<=limit && (c==@' ' || c==tab_mark) );

    if(nuweb_mode)
        {
        if(!(c == @'@@' && *loc == @'#'))
            { /* Go back to beginning. */
            loc = loc0;
            c = *loc++;
            }
        }
    }
}

@ Parse \TeX\ code.
@<Part 2@>=@[
GOTO_CODE prs_TeX_code(VOID)
{
GOTO_CODE icode; // Return code from |get_control_code|.

if(loc>limit)
    return MORE_PARSE;

if(TeX[c] == TeX_comment)
    @<Handle \TeX\ comment@>@;

if (c==@'@@')
    {
    icode = get_control_code();

    if(icode == MORE_PARSE)
        return icode;

    if((int)(icode) < 0)
        return prs_regular_code(icode);
    else
        return (eight_bits)icode;
    }
else
    @<Get \TeX\ string@>@;
}

@ Generally, comments are retained (|keep_trailing_comments==YES| by
default) if they don't start a line.

@<Handle \TeX\ comment@>=
{
long_comment = NO;

if((all_cmnts_verbatim || (keep_trailing_comments && !at_beginning))
        && !(scanning_defn && is_WEB_macro))
    {
    strt_cmnt = YES;
    }
else
    {
    loc = limit + 1; // Skip rest of line.
    return MORE_PARSE;
    }
}

@
@<Get \TeX\ string@>=
{
loc--;
id_first = id_loc = mod_text + 1;

if(strt_cmnt)
    *id_loc++ = begin_Xmeta;

while(loc < limit)
    {
    if(*loc == @'@@')
        {
        if(*(loc+1)==@'@@')
            *id_loc++ = *loc++;
@#if 0
        else break;
@#endif
        }
    else if(!strt_cmnt && TeX[*loc] == TeX_comment && *(loc-1) != @'\\')
        break;

    *id_loc++ = *loc++;
    }

if(strt_cmnt)
    *id_loc++ = end_Xmeta;

return stringg;
}

@ Parse all languages except \TeX.  Certain parts of this can be called by
means of the |iswitch| argument.
@<Part 2@>=@[
GOTO_CODE prs_regular_code FCN((iswitch))
    GOTO_CODE iswitch C1("")@;
{
GOTO_CODE icode; // Return code from |get_control_code|.

switch(iswitch)
    {
   case MORE_PARSE: break;

   case GOTO_MISTAKE: goto mistake;
   case GOTO_GET_IDENTIFIER: goto get_identifier;
   case GOTO_GET_A_STRING: goto get_a_string;
   case GOTO_SKIP_A_COMMENT: goto skip_a_comment;
    }

if(language != LITERAL)
    @<Check for ordinary comments@>@;

/* --- ELLIPSIS --- */
if(c==@'.' && *loc==@'.' && *(loc+1)==@'.')
    {
    ++loc;
    compress(ellipsis);
    }

/* --- DOT CONSTANT: `\.{.FALSE.}' --- */
else if(FORTRAN_LIKE(language) && dot_constants &&
        (c == wt_style.dot_delimiter.begin) && !isDigit(*loc))
    @<Try to identify a dot constant@>@;

/* --- CONSTANT: `\.{123}', `\.{.1}', or `\.{\\135}' --- */
else if (isDigit(c) || c==@'\\' || c==@'.')
    @<Get a constant@>@;

/* --- IDENTIFIER --- */
else if(is_identifier(c))
    @<Get an identifier@>@;

/* --- STRING --- */
else if ( (c==@'\'' || c==@'"')
         || (is_RATFOR_(language) && sharp_include_line==YES && c==@'(') )
    {
    if(language == LITERAL)
        return c;
    else
        @<Get a string@>@;
    }

/* --- CONTROL CODE --- */
else if (c==@'@@')
    @<Get a control code@>@;

/* --- WHITE SPACE --- */
else if (c==@' ' || c==tab_mark)
    if(nuweb_mode)
        return (c==tab_mark ? bell : c);
    else
        {
        if (!preprocessing || loc>limit) return MORE_PARSE;
          /* we don't want a blank after a final backslash */
        else return @' ';
            // Ignore spaces and tabs, unless preprocessing.
        }

/* --- C PREPROCESSOR COMMAND --- */
else if (c==@'#' && at_beginning && C_LIKE(language))
    {
    preprocessing = YES;
    return MORE_PARSE;
    }

/* --- END of |@r format| STATEMENT --- */
else if (in_format && c==@';') /* End a |@r format| statement. */
    {
    in_format = NO;
    return end_format_stmt;
    }

/* --- TWO-SYMBOL OPERATOR --- */
mistake:
 if(language != LITERAL)
    @<Compress two-symbol operator@>@;

return (eight_bits)c;
}


@
@<Check for ordinary comments@>=
{
switch(c)
    {
   case (ASCII)begin_comment0:
    long_comment = strt_cmnt = YES;
    break;

   case (ASCII)begin_comment1:
    strt_cmnt = strt_point_cmnt = YES;
    long_comment = NO;
    break;

   case @'/':
    if(*loc==@'*')
        long_comment= strt_cmnt = YES;
    else if(*loc==@'/' && (C_LIKE(language) || (Cpp_comments &&
!in_format && FORTRAN_LIKE(language))))
        { // Short comments are recognized in both~C and \Cpp.
        long_comment = NO;
        strt_cmnt = YES;
        }
    break;

   case @'!':
/* \Fortran\ will handle the commenting style ``\.{! Comment}'' if
|point_comments| is on, or ``\.{!! Comment}'' always. */
    if((*loc==@'!' || point_comments) && FORTRAN_LIKE(language))
        {
        *(loc-1) = (ASCII)begin_comment1; /* This marker is
necessary so the verbatim comments don't get confused with \.{@@!}. */
        strt_cmnt = strt_point_cmnt = YES;
        long_comment = NO;
        }
    break;
    }

if(strt_cmnt && all_cmnts_verbatim && !(scanning_defn && is_WEB_macro))
    {
    loc--; /* Position on the '\./'. */

    @<Get a control code@>@;
    }
else if(strt_cmnt || comment_continues)
    {
    skip_a_comment:
          skip_comment(); /* scan to end of comment or newline */

          if ((comment_continues  || !long_comment) &&
            !(scanning_defn && is_WEB_macro)) return @'\n';
          else return MORE_PARSE;
     }

if(loc==limit && c==cont_char &&
    (preprocessing || (auto_semi && R77)) ) return MORE_PARSE;
@#if(0)
    if(auto_semi && loc==limit && c==cont_char && R77) return MORE_PARSE;
@#endif
}

@ The following code assigns values to the combinations \.{++},
\.{--}, \.{->}, \.{>=}, \.{<=}, \.{==}, \.{<<}, \.{>>}, \.{!=}, \.{||} and
\.{\&\&}.  The compound assignment operators (e.g., \.{+=}) are
separate tokens, according to the \ceeref. (They're not, according to ANSI.
Pragmatically, there's no more room in the table for more single-byte tokens.)

@d compress(c) if (loc++<=limit) return (eight_bits)(c)
@d Fcompress(c) if( is_FORTRAN_(language) && loc < limit)
            return (eight_bits)(c) /* Not used. */
@<Compress two...@>=
switch(c)
 {
  case @'/':
  case @'\\':
    if(FORTRAN_LIKE(language) && !in_format && (*loc == @'/') )
        {
        if(Cpp_comments && c==@'/') break; /* In this case, the
slashes are the \Cpp-style comments.  We'll always allow \.{\\/} as a
synonym for concatenation. */

        compress(slash_slash); /* \Fortran's concatenation
operator. Multiple slashes in |format| statements are just left alone. */
        }
    break;
  case @'+': if (*loc==@'+') compress(plus_plus);  break;

  case @'-': if (*loc==@'-') {compress(minus_minus);}
    else if (*loc==@'>') compress(minus_gt);  break;

  case @'=': if (*loc==@'=') compress(eq_eq);  break;

  case @'>': if (*loc==@'=') {compress(gt_eq);}
    else if (*loc==@'>') {compress(gt_gt);}
    break;

  case @'<': if (*loc==@'=') {compress(lt_eq);}
    else if (*loc==@'<') {compress(lt_lt);}
    else if(*loc==@'>') {compress(not_eq);} /* \FORTRAN-88 */
    break;

  case @'&': if (*loc==@'&') compress(and_and);  break;

  case @'|': if (*loc==@'|') compress(or_or);  break;

  case @'!': if (*loc==@'=') {compress(not_eq);} break;

  case @'*':
    if(FORTRAN_LIKE(language) && (*loc == @'*') )
        {compress(star_star);} /* Exponentiation. */
    break;

 case @'^':
    if(*loc == @'^') {compress(star_star);}
    else if(FORTRAN_LIKE(language) && (loc < limit) ) return star_star;
    break;

 case @'#':
    if(*loc==@'#') {compress(paste);}
    else if(*loc==@'<')
        {
        loc++;
        mac_mod_name = YES;
        @<Scan the module name and make |cur_module| point to it@>;
        }
    break;

  case @':': if(*loc==@':') compress(colon_colon); @+ break;

}


@ We need a few flags for processing constants.
@<Glob...@>=

EXTERN boolean starts_with_0, hex_constant, bin_constant, floating_constant;

@
@<Get a constant@>=
@{
boolean decimal_point;

@b
if(loc==limit && c==cont_char)
    {
    if(preprocessing) loc++;
    return (eight_bits)c;
    }

starts_with_0 = hex_constant = bin_constant = floating_constant = NO;

  id_first = loc - 1;

  if (*id_first==@'.' && !isDigit(*loc)) goto mistake; /* not a constant */

  if (*id_first==@'\\')
    {
    if(*loc == @'/') goto mistake;
    while (isOdigit(*loc)) loc++; /* octal constant */
    goto found;
    }
  else
     {
     starts_with_0 = BOOLEAN(*id_first==@'0');
     if (starts_with_0)
    {
    hex_constant = BOOLEAN(*loc==@'x' || *loc==@'X');

        if (hex_constant)
        { /* hex constant---e.g, \.{0xA1} */
            loc++; while (isXdigit(*loc)) loc++; goto found;
        }
    else if( (bin_constant=BOOLEAN(*loc==@'b' || *loc==@'B')) != 0 )
        { /* Binary constant---e.g., |0b101|. */
        loc++;
        while(isBdigit(*loc)) loc++;
        goto found;
        }
    }

while(isDigit(*loc)) loc++; /* Skip over digits. */
decimal_point = BOOLEAN(*loc==@'.');
if(decimal_point) loc++; /* Check if decimal point. */
while(isDigit(*loc)) loc++; /* Skip over digits after decimal point. */

    if(FORTRAN_LIKE(language))
        if(*(loc-1)==@'.')
            {
/* If the constant doesn't end with a digit,
make sure the dot isn't the start of a dot constant. */
            if(is_dot())
                {
                loc--;
                goto found;
                }
            }
        else if(*loc == @'h' || *loc == @'H')
            @<Get Hollerith string, |goto found|@>@;

    floating_constant = BOOLEAN(*loc==@'e' || *loc==@'E' ||
            (FORTRAN_LIKE(language)
        && (*loc==@'d' || *loc==@'D' || *loc==@'q' || *loc==@'Q')));

    if(floating_constant)
        { /* float constant---e.g., \.{1.0e-5}  */
        if (*++loc==@'+' || *loc==@'-') loc++;
            while (isDigit(*loc)) loc++;
            }

    floating_constant |= decimal_point;
  }

  found:
    if (C_LIKE(language))
        { /* Check for |unsigned|, |long|, or |float| suffix. */
        boolean its_long = NO, its_unsigned = NO, its_constant = NO;

        switch(*loc)
            {
           case @'l':
           case @'L':
            its_constant = its_long = YES;
            break;

           case @'u':
           case @'U':
            its_constant = its_unsigned = YES;
            break;

           case @'f':
           case @'F':
            its_constant = YES;
            break;
            }

        if(its_constant)
            { /* |long|, |float|, or |unsigned|
constant---e.g., \.{123L} */
            loc++; // Skip over suffix.

/* Might be a second suffix. */
            if(its_long && (*loc == @'u' || *loc == @'U'))
                loc++; // |50LU|
            else if(its_unsigned && (*loc == @'l' || *loc ==@'L'))
                loc++; // |50UL|
            }
        }
    else if(Fortran88) @<Skip over optional kind parameter@>@;

  id_loc = loc;
  return constant;
}

@ For \Fortran-90.
@<Skip over optional kind...@>=
{
if(*loc == @'_')
    while(is_kind(*loc)) loc++;
}

@
@<Get Hollerith string...@>=
@{
int l,n;

@b
*loc++ = '\0'; /* Terminate string after the length
    (temporarily overwriting the 'H'); position to actual constant. */
n = ATOI(id_first); /* Length of constant. */
*(loc-1) = @'H'; /* Reconstruct the 'H'. */

for(l = 0; l<n; ++l) ++loc; /* Skip over the constant. */

goto found;
}

@
@<Try to identify a dot...@>=
@{
ASCII HUGE *p0;
int n;
eight_bits c;
ASCII dot_end = wt_style.dot_delimiter.end;

@b
/* At this point, |loc| is positioned to the first position after the dot. */
for(p0=loc, n=0; n<MAX_DOT_LENGTH; n++,loc++)
    if(*loc == dot_end || !isAlpha(*loc)) break; /* Found end of dot
constant. */

if(*loc != dot_end) /* Didn't find end. */
    {
    loc = p0; /* Reset position back to beginning. */
    goto mistake;
    }

c = dot_code(dots,uppercase(p0,n),loc++,dot_const);

if(c) return c;
else
    {
    loc = p0;
    goto mistake;
    }

}

@ Strings and character constants, delimited by double and single
quotes, respectively, can contain newlines or instances of their own
delimiters if they are protected by a backslash (for C---e.g., |"ab\"c"|)
or if they are
repeated (for FORTRAN---e.g., |@r 'ab''c'|).  We follow this convention,
but do not allow the string to be longer than |longest_name|.

@<Get a string@>=
get_a_string:
{
  ASCII delim = c; /* what started the string */
  ASCII right_delim = c;
  int level;
boolean equal_delims;

  id_first = mod_text+1; /* Position of delimiter. */
  id_loc = mod_text; *++id_loc=delim;

  if(delim==@'(')
    {
     right_delim = @')'; /* For m4 |@r include|. */
    sharp_include_line = NO;
    }

level = 1;

equal_delims = BOOLEAN(right_delim==delim);

WHILE()
{
    if (loc>=limit)
    {
      if( (equal_delims || chk_ifelse) && *(limit-1)!=cont_char)
            /* Continuation after next line. */
        {
            err_print(T,"String %s with '%s%c' didn't end",
            BTRANS, delim==@'\'' ? "\\" : "", XCHR(delim));
        loc=limit; break;
@.String didn't end@>
          }

      if(!get_line())
        {
            err_print(T,"Input ended in middle of string \
%s with '%s%c'", BTRANS, delim==@'\'' ? "\\" : "", XCHR(delim));
        loc=cur_buffer;
        break;
@.Input ended in middle of string@>
          }
      else
    {
    if (C_LIKE(language) && ++id_loc<=mod_end) *id_loc = @'\n';
/* More string to come; will print as \.{"\\\\\\n"} */

/* Now the continuation of the string is in the buffer.  If appropriate,
skip over beginning white space and backslash. */
    if(bslash_continued_strings)
        {
        for(; loc < limit; loc++)
            if(*loc != @' ' && *loc != tab_mark) break;

        if(*loc == cont_char) loc++; /* Move past the backslash. */
        else err_print(T,"Inserted '%c' at beginning of continued \
string",XCHR(cont_char));
        }
    }
    }

    if(!equal_delims) @<Skip over embedded comment@>;

    if ((c=*loc++)==delim)
    {
    level++;

      if (++id_loc<=mod_end) *id_loc=c;

    if(!equal_delims) continue;

    if( *loc==delim && !(C_LIKE(language) ||
             (is_RATFOR_(language) && Ratfor77)) )
        ++loc; /* Copy over repeated delimiter. */
    else   break; /* Found end of string. */
        }

    if(c==right_delim)
        if(--level == 0)
            {
          if (++id_loc<=mod_end) *id_loc=c;
         break; /* Found end of string for unequal delims. */
            }

/* Double the quote. */
    if(R77 && c==@'\'')
        if(++id_loc <= mod_end) *id_loc = c;

    if (c==cont_char)
    {
      if (loc>=limit && (!is_FORTRAN_(language) || free_form_input))
        continue; /* Continuation of string; throw away the
continuation character. */

    if(!is_FORTRAN_(language))
    {
      c = *loc++; /* Character after backslash. */

    if(R77)
       switch(c)
        {
#if(0)
#define n c
        @<Convert escape characters@>@;
#undef n
#endif
/* Double the quote for the direct-to-Fortran output. */
        case @'\'':
            if(++id_loc <= mod_end) *id_loc = c;
            break;
        }
    else {if (++id_loc<=mod_end) *id_loc = @'\\';}
    }
        }

    if (++id_loc<=mod_end) *id_loc=c; /* Store the character. */
  }

found_string:
  if (id_loc>=mod_end) {
    SET_COLOR(error);
    printf("\n! String too long: ");
@.String too long@>
    ASCII_write(mod_text+1,25);
    printf("..."); mark_error;
  }

  id_loc++;
  return stringg;
}

@ For parenthesized strings, we shall eat embedded C-style comments.
@<Skip over embedded...@>=

if(*loc==@'/' && *(loc+1)==@'*')
    for(loc += 2; ; loc++)
        {
        if(loc >= limit)
            if(!get_line())
                {
        err_print(T,"Input ended in middle of embedded comment %s",
            BTRANS);
                loc = cur_buffer;
                goto found_string;
                }

        if(*loc==@'*' && *(loc+1)==@'/')
            {
            loc += 2;
            break;
            }
        }

@ After an \.{@@}~sign has been scanned, the next character tells us
whether there is more work to do.

@<Get a control code@>=
switch(icode=get_control_code())
    {
   case GOTO_MISTAKE: goto mistake;
   case GOTO_GET_A_STRING: goto get_a_string;
   case GOTO_GET_IDENTIFIER: goto get_identifier;
   case GOTO_SKIP_A_COMMENT: goto skip_a_comment;

   case MORE_PARSE:
   default: return icode;
    }

@
@<Part 2@>=@[
GOTO_CODE get_control_code(VOID)
{
eight_bits cc; /* The |ccode| value. */

c = *loc++;
SET_CASE(c); // Set the |upper_case_code| flag.

if(c == (ASCII)begin_comment1 || c == (ASCII)begin_comment0)
    {
    c = *(loc-1) = @'/'; /* So we can handle this uniformly with C-style
comments. */
    strt_cmnt = YES;
    }

switch(cc=ccode[c])
    {
    case ignore: return MORE_PARSE; /* Undefined control code. */

/* Languages are stored, if necessary, in two parts: |begin_language|, and
the language itself. Here |set_output_file| sets the language, which can be
looked at when we're appending. */
   @<Specific language cases@>:
    loc--;

   case L_switch:
    {
    @<Set |language|@>@;
    set_output_file(language);
    return begin_language;
    }

    case control_text: while ((c=skip_ahead(ignore,NO))==@'@@');
      /* only \.{@@@@} and \.{@@>} are expected */ /* Is |c| used?? */

      if (*(loc-1)!=@'>')
    err_print(T,"Improper @@ within control text %s", BTRANS);
@.Improper \AT! within control text@>

      return MORE_PARSE; /* To top of loop in |get_next|. */

    case module_name: /* \.{@@<} */
    mac_mod_name = NO; /* Used as a flag for macro processing. */
    @<Scan the module name and make |cur_module| point to it@>;

    case stringg: /* \.{@@=} */
    @<Scan a verbatim string@>;

    case begin_vcmnt:
/* Here the |strt_cmnt| handles all comments verbatim; the last two
cases handle~\.{@@\slashstar} or~\.{@@//}. */
    if(strt_cmnt || *loc==@'*' || *loc==@'/')
        if(!(scanning_defn && is_WEB_macro) && !deferred_macro)
            {
            if(!strt_point_cmnt) long_comment =
                BOOLEAN(!(*loc==@'/'));
            @<Scan a verbatim comment@>@;  /* \.{@@\slashstar} */
            }
        else return GOTO_SKIP_A_COMMENT;
    else return MORE_PARSE; /* The line-break command \.{@@/} is ignored by
\TANGLE. */

    case invisible_cmnt:
/* When we sense an \.{@@\%}, we throw away everything to the end of line,
including the newline that is normally returned.  */
    if(*loc == @'%')
        eat_blank_lines = YES;

    loc = limit + 1; // Force the next line to be read.
    suppress_newline = YES;
    return MORE_PARSE;

    case compiler_directive:
        {
        int n;
        outer_char *s = t_style.cdir_start[language_num];

        id_first = id_loc = mod_text + 1;

        *id_loc++ = cdir;

/* Starting ``pragma'' string. */
        STRCPY(id_loc,s);
        to_ASCII((outer_char HUGE *)id_loc);
        id_loc += STRLEN(s);

/* Body. */
        STRNCPY(id_loc,loc,n = limit - loc);
        id_loc += n;

        *id_loc++ = cdir;
        *id_loc++ = '\0';

        loc = limit + 1;
        return stringg;
        }

    case Compiler_Directive:
        {
        outer_char *s = t_style.cdir_start[language_num];

        id_first = id_loc = mod_text + 1;

        *id_loc++ = cdir;
        preprocessing = in_cdir = YES;
        at_beginning = NO;

/* Starting ``pragma'' string. */
        STRCPY(id_loc,s);
        to_ASCII((outer_char HUGE *)id_loc);
        id_loc += STRLEN(s);

        return stringg;
        }

    case new_output_file: // \.{@@o}
    @<Scan the output file name@>@;
    loc = limit + 1; // Skip rest of line.
    return cc;

    case ascii_constant: /* \.{@@'} or \.{@@"} */
    if(translate_ASCII) @<Scan an |ASCII| constant@>@;
    else
        {
        c = *(loc-1); // The starting quote character.
        return GOTO_GET_A_STRING;
        }

    case big_line_break: /* \.{@@\#}. Serves double duty as line break or
preprocessor command. ??? GENERALIZE??? */
    if(loc >= limit) return MORE_PARSE;

    @<Process possible preprocessor command@>;
    return MORE_PARSE;

    case USED_BY_NEITHER:
    err_print(T,"Invalid `@@%c' ignored",XCHR(c));
    return ignore;

    default: return cc;
  }
}

@ Here we copy over the contents of an |ASCII| constant or string.
@<Scan an |ASCII|...@>=
{
ASCII delim = *(loc-1); // Character that started the string.

  id_first = loc - 1; // Include the delimiter for later reference.

  while(*loc != delim)
    {
    if (*loc == @'\\')
        if(*++loc == delim)
            { /* Skip over escape, and possibly escaped
delimiter. */
            loc++;
            continue;
            }

    loc++;

    if (loc>limit)
        {
            err_print(T,"ASCII string %s didn't end", BTRANS);
        loc=limit-1; break;
        }
    }

  loc++; // Skip closing delimiter.
  return ascii_constant;
}

@ Process the stuff after~\.{@@<} or~\.{\#<}.
@<Scan the module name...@>=
@{
  ASCII HUGE *k; /* pointer into |mod_text| */
  static ASCII ell[] = @"...";

@b
  @<Put module name into |mod_text|@>@;

  if (k-mod_text>3 && STRNCMP(k-2,ell,3)==0)
    cur_module=prefix_lookup(mod_text+1,k-3);
  else cur_module=mod_lookup(mod_text+1,k);

if(cur_module != NULL)
    {
    set_output_file(cur_module->mod_info->language); /* Get current
language. */
    }

return module_name;
}

@ Module names are placed into the |mod_text| array with consecutive spaces,
tabs, and carriage-returns replaced by single spaces. There will be no
spaces at the beginning or the end. (We set |mod_text[0]=' '| to facilitate
this, since the |mod_lookup| routine uses |mod_text[1]| as the first
character of the name.)

@<Set init...@>=

mod_text[0]=@' ';

@
@<Put module name...@>=
{
int mlevel = 1; // For nested module names.

k = mod_text;

WHILE()
    {
    if (loc>limit && !get_line())
        {
        err_print(T,"Input ended in section name %s", BTRANS);
@.Input ended in section name@>
        loc=cur_buffer+1; break;
        }

      c = *loc;
      @<If end of name, |break|@>;
      loc++;

    if (k<mod_end) k++;

    switch(c)
        {
       case @' ':
       case tab_mark:
        c=@' '; if (*(k-1)==@' ') k--; // Compress white space.
        break;

       case @';':
        c = interior_semi;
        break;
        }

    *k = c;
    }

if (k>=mod_end) {
    SET_COLOR(warning);
  printf("\n! Section name too long: ");
@.Section name too long@>
  ASCII_write(mod_text+1,25);
  printf("..."); mark_harmless;
}

if (*k==@' ' && k>mod_text) k--; // Trailing blanks.
}

@
@<If end of name,...@>=

if (c==@'@@')
    {
    c=*(loc+1);

    if (c==@'>')
        {
        if(--mlevel == 0)
            {
            loc+=2; break; // Successful; position after \.{@@>}.
            }
        }
    else if(c==@'<') mlevel++;

    if (ccode[c]==new_module)
        {
        err_print(T,"Section name %s didn't end", BTRANS);
@.Section name didn't end@>
        break;
        }

    *(++k)=@'@@'; loc++; // Now |c==*loc| again.
    }

@ Verbatim comments (C-style comments preceded by~`\.{@@}'), are
essentially copied intact to the output. Here, we put the comment into the
|mod_text| buffer; we set |id_first| to the beginning, |id_loc| to the
end-plus-one, and |loc| to the position after the end-of-comment.

@<Scan a verbatim comment@>=
{
loc--; /* Position to the beginning slash or comment marker (which has been
        already read as part of~`\.{@@/}'). */

id_first = id_loc = mod_text + 1; /* A convenient place to put the verbatim
                    comment. */

if(!C_LIKE(language))
    {
    loc++;    /* Skip the opening \.*, for beauty. */
    @<Make newline and comment character@>;
    }

WHILE()
    {
    if(loc > limit)
      if(!long_comment) @<Finish comment and |break|@>@;
      else if(!get_line())
        {
        err_print(T,"Input ended in verbatim comment %s", BTRANS);
@.Input ended in verbatim comment@>
        loc = cur_buffer + 1;
        break;
        }
      else
        {
        *id_loc++ = @'\n'; /* Retain line breaks in comments. */

        if(R66)
            {
            *id_loc++ = @'#'; /* Special comment line. */
            *id_loc++ = @' '; /* Space adds readability. */
            }
        }

    if(id_loc < mod_end - 3)
        *id_loc++ = *loc++; /* Copy over the comment. */
    else
        {
        SET_COLOR(warning);
        printf("\n! Verbatim comment too long: ");
@.Verbatim comment too long@>
        ASCII_write(mod_text,25);
        printf("..."); mark_harmless;

        id_loc = mod_end - 3;
        *id_loc++ = @'*'; *id_loc++ = @'/'; /* Terminate the comment
(prematurely). */
        comment_continues = YES; /* This is so |get_next| can skip
the remainder of the comment. */
        goto finish_vcmnt;
        }

/* Check for end of verbatim comment. */
    if(long_comment && *loc == @'/' && *(loc-1)==@'*')
        {
        *id_loc++ = *loc++; /* Position after end of comment. */
        @<Finish comment and |break|@>@;
        }
    }

finish_vcmnt:
    if(!C_LIKE(language))
        {
        *id_loc++ = '\0';
        }
    return stringg; /* Complete comment copied. */
}


@
@<Finish comment...@>=
{
if(C_LIKE(language))
    { /* If we're not using \Cpp, we'll change short comments back to
standard form so they can be understood by the compiler. */
    if(!long_comment && !Cpp)
        {
        *id_loc++ = id_first[1] = @'*';
        *id_loc++ = id_first[0] = @'/';
        }
    }
else
    { /* In \Fortran, kill off the trailing terminator. */
    if(long_comment) id_loc -= 2;
    }

break;
}

@ Verbatim comments not in~C must start on a new line, and must be prefixed
with a comment character.
@<Make newline and c...@>=
{
if(R66) *id_loc++ = @'#';
else *id_loc++ = @'\n';

}

@ At the present point in the program we have |*(loc-1)=stringg|; we set
|id_first| to the beginning of the string itself, and |id_loc| to its
ending-plus-one location in the buffer.  We also set |loc| to the position
just after the ending delimiter.

@<Scan a verbatim string@>=
{
id_first = loc; /* This used to be |loc++|, but that doesn't handle null
        string correctly. */

*(limit+1) = @'@@'; *(limit+2) = @'>'; // Delimiters for verbatim string.

while (*loc != @'@@' || *(loc+1) != @'>')
    loc++; // Verbatim string must end on same line.

if (loc >= limit) err_print(T,"Verbatim string %s didn't end", BTRANS);
@.Verbatim string didn't end@>

id_loc = loc;
loc += 2; // Just after \.{@@>}.
return stringg;
}

@* GENERATING REPLACEMENT TEXTS.  The rules for generating the replacement
texts corresponding to macros and \cee\ texts of a module are almost
identical; the only differences are that

{\narrower
\yskip \item{a)}Module names are not allowed in macros;
in fact, the appearance of a module name terminates such macros and denotes
the name of the current module.

\item{b)}The symbols \.{@@d}, \.{@@f}, and \.{@@a} are not allowed after
module names, while they terminate macro definitions.

}

\yskip Therefore there is a single procedure |scan_repl| whose parameter
|t| specifies either |macro| or |module_name|. After |scan_repl| has acted,
|cur_text| will point to the replacement text just generated, and
|next_control| will contain the control code that terminated the activity.

/* In certain contexts, it is required to stop the scan at the end of the
current line. */
@d STOP (boolean)YES
@d DONT_STOP (boolean)NO

/* Add a token to |token_mem|. */
@d app_repl(c)  {if (tok_ptr==tok_m_end)
                OVERFLW("tokens",ABBREV(max_toks_t));
            *tok_ptr++= (eight_bits)(c);}

@<Global...@>=

EXTERN text_pointer cur_text; // Replacement text just formed by |scan_repl|.

EXTERN eight_bits next_control;

@ Creates a replacement text.
@<Part 3@>=@[

SRTN scan_repl FCN((t,stop))
    eight_bits t C0("Either |macro| or |module_name|.")@;
    boolean stop C1("IF |YES|, stops the scan at the end of current\
line.")@;
{
eight_bits a0 = ignore;  /* the current token */
sixteen_bits a; /* An identifier number. */
LANGUAGE language0;
int ntoken = 2;
boolean auto_bp = YES; /* Breakpoints are inserted automatically, unless
the module starts off with \.{@@\lb}. */
boolean scanning_meta = NO;

language0 = language; /* Save incoming language, in case while we're
            reading ahead we change it. */
stop_the_scan = stop;

if (t==module_name)
    @<Insert the line number into |tok_mem|@>;
else if(stop)
    @<Stop scan@>@;

WHILE()
    {
    if(stop)
        {
        while(loc <= limit)
            if(*loc != @' ') break;
            else loc++;

        if(loc > limit) goto done;
        }

/* The |ntoken| counter starts out at~2. It is used to see whether the
first thing in the module is a left brace. If so, the |_BP| macro is
inserted after the brace for debugging purposes. */
    if(ntoken)
        ntoken--;

    a0 = (ntoken && nuweb_mode && t==module_name)
        ? begin_meta : get_next(); // !!!!!

reswitch:
    switch(a0)
        {
       case @'\\':
         if(loc==limit && language!=LITERAL)
            {
            if(!get_line())
                FATAL("!! Input ended while scanning \
WEB preprocessor statement","");
            @<Stop scan@>@;
            }
        else
            {
            app_repl(a0);

            if(language == LITERAL)
                loc++;
            }
        break;

       case @'#':
        if(t==macro && is_WEB_macro)
            @<Possibly insert statement number@>@;
        else
            {
            app_repl(a0);
            }
        break;

          @<In cases that |a0| is a non-ASCII token (|identifier|,
        |module_name|, etc.), either process it and change |a0| to a byte
        that should be stored, or |continue| if |a0| should be ignored,
        or |goto done| if |a0| signals the end of this replacement text@>@;

@#if(0)
    case @'\n':
        if(is_WEB_macro) continue;
@#endif

       case @'\n':
/* As far as checking whether a left brace begins a module, we don't care
about newlines. */
        if(ntoken) ntoken++;
        app_repl(a0);
        break;

       case @'{':
        app_repl(a0);

        if(ntoken && breakpoints && t==module_name&&auto_bp)
            @<Insert the |_BP| macro for debugging@>@;

        break;

       case begin_bp:
        auto_bp = NO; // A manual insertion command is coming up.
        app_repl(@'{');
        break;

       case insert_bp:
        if(breakpoints)
            @<Insert the |_BP|...@>@;
        break;

       default:
        app_repl(a0); // Store |a0| in |tok_mem|.
        break;
        }
    }

  done:
    if(stop_the_scan && !from_buffer)
        {
        stop_the_scan = NO;
        next_control = ignore;
        }
    else next_control =
        (eight_bits)CHOICE((from_buffer && loc > limit) || stop,
                ignore, a0);

@<Make |cur_text = text_ptr|; update |text_ptr|@>;
cur_text->Language = (boolean)language0; // Use the starting language.
}

@ For modules that start with a left brace, if the |_BP| macro has been
defined and/or we're in the debugging mode, then while we're reading things
in we insert a call to that macro, with arguments the module number and
module name. We build the call into the temporary buffer |bp_cmd|, then
divert the input stream into that buffer.

@d BP_BUF_SIZE (13 + MAX_ID_LENGTH) /* The print command below generates a
    string of the form ``\.{\_BP(99999,"\dots")}'', where the \dots\
    correspond to |name_of|, whose maximum length is |MAX_ID_LENGTH|. */

@<Insert the |_BP|...@>=
{
ASCII bp_cmd[BP_BUF_SIZE];

if(cur_module != NULL)
    {
    SPRINTF(BP_BUF_SIZE,bp_cmd,`"_BP(%d,\"%s\")",
        module_count,name_of((sixteen_bits)(cur_module-name_dir))`);
    to_ASCII(OC(bp_cmd));
    divert(bp_cmd,bp_cmd+STRLEN(bp_cmd),DONT_STOP);
    }
}

@ If the user has defined the macro |_BP| from the command line, then we
turn on the |breakpoints| flag so the macro can be inserted in front of
every module beginning with a left brace.
@<Glob...@>=

EXTERN boolean breakpoints;

@
@<Has the |_BP| macro been defined?@>=
@{
IN_COMMON ASCII HUGE *pbp;

@b
breakpoints = BOOLEAN(MAC_LOOKUP(ID_NUM(pbp,pbp+3)) != NULL);
}

@ (Sometimes used during debugging.)
@<Define internal...@>=

@#if(0)
    SAVE_MACRO("_BP(m,name)");
@#endif

@
@<Make |cur_text...@>=
{
if (text_ptr>text_end) OVERFLW("texts",ABBREV(max_texts));
cur_text = text_ptr;
(++text_ptr)->tok_start = tok_ptr; /* The next start is the present end. */
}

@ Prevent macro scan for \.{@@\#if(...)} from overrunning end of line, by
inserting a |WEB_definition| command at the end.
@<Stop scan@>=
{
*limit = @' ';
*(limit+1) = @'@@';
*(limit+2) = @'m';
}

@ For inserting the line number, we use a function call to keep the code small.
@<Insert the line number into |tok_mem|@>=ins_ln_no()@;

@ Here is the code for the line number: first a |sixteen_bits| equal to
$|0150000| \equiv |LINE_NUM|$; then, if we're dealing with the change file,
the line number plus |0100000|; or, if we're dealing with the web file, the
line number; or, if we're dealing with an include file, the number 0, then
the line number, followed by the number of characters in the file name and
the file name.

@<Part 3@>=
SRTN ins_ln_no(VOID)
{
name_pointer np;

store_two_bytes((sixteen_bits)LINE_NUM); // $\equiv$ a mod.\ \# of~0.

if(line_info)
    {
    id_first = x_to_ASCII(changing ? change_file_name : cur_file_name);
    id_loc = id_first + STRLEN(id_first);

    store_two_bytes((sixteen_bits)(changing ? change_line : cur_line));

    store_two_bytes(ID_NUM_ptr(np,id_first,id_loc));
    np->Language = (boolean)NO_LANGUAGE; // \bfit Is this used???
    }
}

@ This fragment stores away an identifier token returned from |id_lookup|.
@<Append identifier token@>=
@{
app_repl(LEFT(a,ID0));
app_repl(RIGHT(a));
}

@
@<Get and append an identifier token@>=

a = ID_NUM(id_first,id_loc);
@<Append identifier token@>@;

@
@<In cases that |a0| is...@>=

case identifier:
    @<Get and append an identifier token@>@;
    break;

case module_name:
/* In a macro, the appearance of a module name beginning with
    \.{@@<} ends the macro and the definition section. On the other
hand, the construction \.{\#<\dots@@>} is OK in a macro. */
 if (t==macro && !mac_mod_name)
    goto done;
 else
  {
    @<Was an '@@' missed here?@>;
    a = cur_module - name_dir;
    app_repl(LEFT(a,MOD0));
    app_repl(RIGHT(a));
    @<Insert the line number into |tok_mem|@>;
    if(nuweb_mode)
    { /* !!!!! */
    a0 = begin_meta;
    goto reswitch;
    }
    break;
  }

case constant:
case stringg:
  @<Copy a string or verbatim construction or numerical constant@>;

case ascii_constant:
  cp_ASCII();
  break;

case begin_meta:
    @<Process |begin_meta|@>@;
    break;

case end_meta:
    @<Start column mode.@>;
    get_line();
    app_repl(end_meta);
@%    app_repl('\0');
    app_repl(stringg);
    scanning_meta = NO;
    break;

case dot_const:
    app_repl(a0);
    app_repl(dot_op.num); // |dot_op| was filled by |dot_code|.
    break;

case begin_language:
    switch(language)
        {
       case NO_LANGUAGE:
        CONFUSION("scan_repl:begin_language","Language isn't defined");

       case RATFOR:
       case RATFOR_90:
        if(!RAT_OK("(scan_repl)"))
            CONFUSION("scan_repl:begin_language",
                "Attempting to append @@Lr");

       case C:
       case C_PLUS_PLUS:
       case LITERAL:
        column_mode = NO;
        break;

       case FORTRAN:
       case FORTRAN_90:
       case TEX:
        if(!(scanning_defn || free_form_input))
            @<Set up column mode@>@;
        break;

       default:
        CONFUSION("app_id","Invalid language");
        }

/* We append the language in two parts: |begin_language|, and the language
itself. This is so we didn't have to tie up many non-printable |ASCII|
tokens. See the inverse code in |get_output|. */
    set_output_file(language);
    if(!scanning_defn)
        {app_repl(a0);app_repl((eight_bits)language);}
    @<Insert the module number into |tok_mem|@>@;
    @<Insert the line number...@>;
    break;

case no_mac_expand:
    app_repl(begin_language);
    app_repl(a0);
    break;

case new_output_file:
    if(t == macro)
        goto done;
    else
        {
        name_pointer np;

        app_repl(begin_language); // We piggy-back on |begin_language|.
        app_repl(NO_LANGUAGE);
        app_repl(upper_case_code); /* Scope of file name:
\.{@@o}~means local; \.{@@O}~means global. */
        a = ID_NUM_ptr(np, id_first, id_loc);
        @<Append identifier token@>@;
        np->macro_type = FILE_NAME; // To prevent truncations.

        if(nuweb_mode)
            {
            a0 = begin_meta;
            goto reswitch;
            }
        }
    break;

case WEB_definition:
    if(t == macro)
        goto done;
    else
        {
        @<Append a deferred macro@>;
        continue;
        }

case begin_nuweb:
    if(t != module_name)
        {
        nuweb_mode1 = !NUWEB_MODE;
        goto done;
        }
    else
        {
    ERR_PRINT(W,"@@N ignored; must appear before beginning of code part");
        continue;
        }

case formatt:
case limbo_text: case op_def: case macro_def:
case definition: case undefinition:
case begin_code:
  if (t!=module_name)
    goto done;
  else
    {
    ERR_PRINT(T,"@@d, @@l, @@v, @@w, @@u, @@f, and @@a \
are ignored in code text");
    continue;
@.\AT!d, \AT!f and \AT!c are ignored in code text@>
    }

case end_of_buffer:
    a0 = ignore;

case m_ifdef: case m_ifndef:
case m_if: case m_else: case m_elif: case m_endif: case m_undef: case m_pragma:
case m_for: case m_endfor:
case new_module:
    goto done;

@
@<Process |begin_meta|@>=
{
app_repl(stringg);
app_repl(a0); /* |begin_meta| inside strings means to insert the
        |meta| stuff from the style file. */

if(FORTRAN_LIKE(language))
    {
    column_mode = NO;
    app_repl(@'\n');
    }

scanning_meta = YES;

}

@
@<Unused@>=
    WHILE()
        {
        if(loc >= limit) // !!!!!!
            if(!get_line())
                {
                if(!nuweb_mode)
        err_print(T,"Input ended during meta-comment %s", BTRANS);
                break;
                }

        while(loc < limit)
            {
            if(*loc == @'@@')
                @<Check for end of meta-comment and |goto
done_meta| if necessary@>@;

            if(is_identifier(*loc))
                @<Append a meta-identifier@>@;
            else
                app_repl(*loc++);
            }

        app_repl(@'\n');
        }


@
@<Append a meta-id...@>=
{
loc++;
@<Make |id_first|...@>@;
@<Get and append an identifier token@>@;
}

@
@<Check for end of meta-comment ...@>=
{
switch(ccode[*(loc+1)])
    {
   case ignore:
   case @'b':
   case @'{':
    if(nuweb_mode) loc += 2;
    break;

   case end_meta:
    @<Start column mode.@>;
    get_line();
    goto done_meta;

   case new_module:
    goto done_meta; // !!!!!

   case @'@@':
    loc++;
    break;

   case invisible_cmnt:
    if(*(loc+2) == @'%')
        eat_blank_lines = YES;

    get_line();

    if(eat_blank_lines)
        {
        eat_blank_lines = NO;

        while(loc >= limit)
            if(!get_line())
                goto done_meta;
        }

    continue;

   default:
    if(nuweb_mode)
        goto done_meta;  // !!!!!

      break;
    }
}

@ When |WEB_definition| is encountered in the code section, it signifies a
deferred macro. This has to be put into the special, deferred pool, not
into the current text being created.
@<Glob...@>=

EXTERN int n_unique SET(0);
EXTERN boolean deferred_macro SET(NO);

@ The deferred macro is referenced from the current text by creating a
special identifier of the form \.{@@}|n_unique|\.{name}, where |n_unique|
is incremented for each new reference to a deferred macro. The |equiv|
field in this identifier points to the deferred pool.

We must do some annoying copying in order to use the same routine
|app_macro|. This could be prettied up.
@<Append a deferred macro@>=
{
#define NAME_LEN 100

name_pointer np;
eight_bits HUGE *tok_ptr0, HUGE *tok_m_end0;
text_pointer text_ptr0,text_end0;
outer_char new_name[NAME_LEN];
ASCII HUGE *nn, HUGE *b;
sixteen_bits a;

if(!deferred_macros)
    {
    ERR_PRINT(T,"Sorry, deferred WEB macros (defined in code part) are \
prohibited; use option `-TD' to permit them");
    continue;
    }

tok_ptr0 = tok_ptr;
tok_m_end0 = tok_m_end;
text_ptr0 = text_ptr;
text_end0 = text_end;

tok_ptr = tok_dptr;
tok_m_end = tokd_end;
text_ptr = txt_dptr;
text_end = textd_end;

deferred_macro = YES;
np = app_macro(WEB_definition);
deferred_macro = NO;

tok_dptr = tok_ptr;
tok_ptr = tok_ptr0;
tok_m_end = tok_m_end0;

txt_dptr = text_ptr;
text_ptr = text_ptr0;
text_end = text_end0;

if(np == NULL) continue;

/* Create a unique name, beginning with '@@'. */
SPRINTF(NAME_LEN,new_name,`"@@%d",n_unique++`);
to_ASCII(new_name);
for(nn=(ASCII *)new_name+STRLEN(new_name),b=np->byte_start;
        b<(np+1)->byte_start; )
    *nn++ = *b++;

a = ID_NUM_ptr(np,(ASCII *)new_name,nn);
@<Append identifier token@>;

np->macro_type = DEFERRED_MACRO;
np->equiv = (EQUIV)cur_text;

#undef NAME_LEN
}

@ Here we handle the cases in which `\.{\#}'~is expanded on \It{input}.
`\.{\#:0}'~expands into a unique statement number.
`\.{\#!}'~followed by a macro token means copy the definition of that
macro, but don't expand it. `\.{\#}'~followed by a macro token means
substitute the complete expansion of that macro.

@<Possibly insert statement...@>=
{
switch(*loc)
    {
   case @':':
    @<Possibly insert a unique statement label@>@; @+ break;

   case @'!':
    if(scanning_defn) @<Copy but don't expand macro@>@;
    else app_repl(@'#');
    break;

   case @'\'':
   case @'"':
    app_repl(a0);
    app_repl(*loc++);
    break;

   default:
    @<Try to expand macro after \.{\#}'@>@;
    break;
    }
}

@
@d N_IDBUF 100
@<Possibly insert a unique statement...@>=
@{
outer_char temp[N_IDBUF];
ASCII HUGE *t;

@b
loc++; /* Move past the colon. */

/* Check if it's '\.0'---immediate statement number. If not, pass it
through to the output phase. */
if(*loc != @'0')
    {
    app_repl(@'#');
    app_repl(@':');
    break;
    }

loc++; /* Move past the zero.*/
SPRINTF(N_IDBUF,temp,`"%lu",max_stmt++`); /* Make the number. */
to_ASCII(temp);

/* Append the number, bracketed by |constant|. */
app_repl(constant);

for(t=(ASCII *)temp; *t != '\0'; t++) app_repl(*t);

app_repl(constant);
}

@ We get to here when on input `\.{\#}' is not followed by `\.!' or `\.:'.
@<Try to expand macro after...@>=
@{
sixteen_bits a;

@b
if(isDigit(*loc) || *loc==@',' || *loc==@'&' || *loc==@'*' || *loc==@'.' ||
        *loc==@'[' || *loc==@'{')
/* It's one of the forms `\.{\#}$nnn$', `\.{\#,}', `\.{\#\&}', `\.{\#*}',
or `\.{\#.}'; these are processed on output. */
    {app_repl(@'#');}
else if(get_next() != identifier)
    MACRO_ERR("! '#' should be followed by identifier",YES);
else
    {
    a = ID_NUM(id_first,id_loc);

/* Check to see if the identifier is an already-defined macro; if not, it's
the stringizing operation, which is processed on output; just
append the identifier. */
    if( (MAC_LOOKUP(a)) == NULL)
        {
        app_repl(@'#');
        @<Append identifier token@>;
        break;
        }

/* Asking for immediate expansion of macro. */
    MACRO_ERR("! Immediate expansion of macro \"%s\" not implemented",
        YES,name_of(a));
    @<Append identifier token@>;
    }
}

@ If the construction `\.{\#!}' is followed by a macro id (without
arguments), then the token definition of that macro is substituted, without
expansion.
@<Copy but don't expand macro@>=
@{
sixteen_bits a;

@b
loc++; /* Position to after `\.!'. */

if(get_next() != identifier)
    ERR_PRINT(M,"Identifier must follow #!; command ignored");
else
    {
    text_pointer m;

 /* Add the identifier to the table if necessary. */
    a = ID_NUM(id_first,id_loc);

/* If it's an identifier but not a macro, it must be the construction
`\.{\#!}|arg|'; just append that for later processing. */
    if( (m=MAC_LOOKUP(a)) == NULL)
        {
        app_repl(@'#');
        app_repl(@'!');
        @<Append identifier token@>;
        break;
        }
    else
        if(m->nargs > 0)
            ERR_PRINT(M,"Macro after #! may not have arguments");
        else @<Copy tokens of macro@>@;
    }
}

@ Here we append the tokens of a macro definition, without expanding them.
@<Copy tokens of macro@>=
@{
eight_bits HUGE *q0, HUGE *q1;

@b
q0 = m->tok_start + m->moffset;
q1 = (m+1)->tok_start;

/* Just copy the definition without expanding. */
while(q0 < q1) app_repl(*q0++);
}

@
@<Was an '@@'...@>=
@{
  ASCII HUGE *try_loc=loc;

@b
  while (*try_loc==@' ' && try_loc<limit) try_loc++;
  if (*try_loc==@'+' && try_loc<limit) try_loc++;
  while (*try_loc==@' ' && try_loc<limit) try_loc++;
  if (*try_loc==@'=')
    ERR_PRINT(T,"Nested named modules.  Missing `@@*' or `@@ '?");
@.Nested named modules@>
}

@ We will {\it bracket} the string or constant with the id token.
@<Copy a string...@>=

if(C_LIKE(language))
    if(bin_constant && a0==constant) @<Convert binary constant@>@;
    else copy_string(a0);
else if(a0 == constant)
    if(hex_constant) @<Convert hex constant@>@;
    else if(bin_constant) @<Convert binary constant@>@;
    else if(starts_with_0 && !floating_constant) @<Convert octal
constant@>@;
    else copy_string(a0);
else if(R77 && a0==stringg && !in_format)
    if(*id_first==@'\'') rdc_char_constant();
    else
        {
/* Replace the Ratfor double quote with Fortran's single quote. Watch out
for a verbatim comment that doesn't start with quote at all. */
        if(*id_first == @'"') *id_first = *(id_loc-1) = @'\'';
        copy_string(a0);
        }
else copy_string(a0);

break;

@
@<Part 3@>=@[
SRTN copy_string FCN((a0))
    eight_bits a0 C1("")@;
{
app_repl(a0); /* |stringg| or |constant| */

while (id_first < id_loc)
    {
    if (*id_first==@'@@') @<Simplify \.{@@@@} pairs@>@;

    app_repl(*id_first++);
    }

app_repl(a0); /* Bracket the string or constant with the id token. */
}

@ The following code changes doubled~\.{@@}'s to a single one.  It also
preserves any language commands, since these can appear inside vertical
bars.  Otherwise, it just deletes the character after the~`\.{@@}', thus
throwing away the entire `\.{@@}'~command.
@<Simplify \.{@@@@} pairs@>=

if(language == TEX && *(id_first+1) == @'@@') id_first++;
else
    {
    id_first++; // Character after the~`\.{@@}'.

    switch(ccode[*id_first])
        {
       case @'@@':
        break;  // The `\.{@@}'~will be stored.

       @<Specific language cases@>:
       case L_switch:
        app_repl(@'@@');
        break; // Retain the character.

       default:
        id_first++; // Discard character after~`\.{@@}'.
        continue;
        }
    }

@
@<Convert hex...@>=
@{
app_converted(xtoi(id_first,id_loc)); // Start after the \.{0x}.
}

@ A function that converts an alpha string to hex.
@<Part 3@>=@[

unsigned long xtoi FCN((b,b1))
    CONST ASCII HUGE *b C0("Beginning of string.")@;
    CONST ASCII HUGE *b1 C1("End of string.")@;
{
unsigned long n = 0;

for(b += 2; b<b1; b++)
    {
    n *= 16;

    if(isDigit(*b)) n += *b - @'0';
    else n += A_TO_UPPER(*b) - @'A' + 10;
    }

return n;
}

@
@<Part 3@>=@[
SRTN app_converted FCN((n))
    unsigned long n C1("")@;
{
ASCII temp[N_IDBUF];
ASCII HUGE *b;

SPRINTF(N_IDBUF,(outer_char *)(temp),`"%lu",n`);
to_ASCII((outer_char *)(temp));

app_repl(constant);
    for(b=temp; *b != '\0'; b++) app_repl(*b)@;
app_repl(constant);
}

@
@<Convert octal...@>=
{
app_converted(otoi(id_first,id_loc));
}

@ A function that converts an octal character string to integer.
@<Part 3@>=@[

unsigned long otoi FCN((b,b1))
    CONST ASCII HUGE *b C0("Beginning of string.")@;
    CONST ASCII HUGE *b1 C1("End of string.")@;
{
unsigned long n = 0;

for(b++; b<b1; b++)
    n = 8*n + *b - @'0';

return n;
}

@
@<Convert bin...@>=
{
app_converted(btoi(id_first,id_loc)); // Start after the \.{0x}.
}

@ A function that converts an binary character string to integer.
@<Part 3@>=@[

unsigned long btoi FCN((b,b1))
    CONST ASCII HUGE *b C0("Beginning of string.")@;
    CONST ASCII HUGE *b1 C1("End of string.")@;
{
unsigned long n = 0;

for(b+=2; b<b1; b++)
    n = 2*n + *b - @'0';

return n;
}

@ In \Ratfor-77 mode, character constants must be converted to integers. We
allow the standard ANSI escapes.
@<Part 3@>=@[
SRTN rdc_char_constant(VOID)
{
int n;

if(*++id_first == @'\\')
    switch(*++id_first)
        {
        @<Convert escape characters@>@;
        default:
            err_print(T,"Invalid escape sequence '\\%c' \
in Ratfor character constant; null assumed",XCHR(*id_first));
            n = 0;
            break;
        }
else n = *id_first;

if(*(id_first+1) != @'\'') ERR_PRINT(T,"Ratfor character constant longer \
than one byte; extra characters ignored");

app_converted(n);
}

@ Here are the standard ANSI escape sequences. The fragment isn't a
complete \&{switch} because we use it in several places, and the
\&{default} differs for each usage.

@<Convert escape char...@>=
        case @'0': n = '\0'; @+ break;
        case @'\\': n = @'\\'; @+ break;
        case @'\'': n = @'\''; @+ break;
        case @'"': n = @'\"'; @+ break;
        case @'?': n = @'\?'; @+ break; /* Microsoft doesn't like. */
        case @'a': n = @'\007'; @+ break; /* SGI didn't understand. */
        case @'b': n = @'\b'; @+ break;
        case @'f': n = @'\f'; @+ break;
        case @'n': n = @'\n'; @+ break;
        case @'r': n = @'\r'; @+ break;
        case @'t': n = @'\t'; @+ break;
        case @'v': n = @'\v'; @+ break;

@ At this point, we're positioned after the~`\.{@@}', on the starting
delimiter in a construction such as~`\.{@@'a'}', `\.{@@'\\n'}',
or~`\.{@@'\\007}'; or `\.{@@"abc"}'.

@<Part 3@>=
SRTN cp_ASCII(VOID)
{
if(*id_first++ == @'\'')
    { /* Single |ASCII| character. */
    if(C_LIKE(language)) app_aconst('o',YES); // Octal (leading zero).
    else app_aconst('d',NO); // Decimal.
    }
else
    { /* Do whole string. */
    if(C_LIKE(language))
        {
        app_repl(@'"');

        while(*id_first != @'"')
            {
            app_repl(@'\\');
            app_aconst('o',NO); // Octal, no leading zero.
            }

        app_repl(@'"');
        }
    else
        {
        sixteen_bits a;
        ASCII delim = (ASCII)(is_RATFOR_(language) ? @'"' : @'\'');
        int n = STRLEN(t_style.ASCII_fcn);

/*  Preface by function call from style file. */
        a = ID_NUM(t_style.ASCII_fcn,t_style.ASCII_fcn+n);
        @<Append identifier token@>@;
        app_repl(@'(');
        app_repl(delim);
        while(*id_first != @'"')
            app_repl(*id_first++);
        app_repl(delim);
        app_repl(@')');
        }
    }

#if(0) /* Keep around for compilers that can't handle the above. */
/* Do whole string, essentially converting to form
``\.{@@'a',@@'b',@@'c'}''. */
    app_repl(@'{');

    while(*id_first != @'"')
        {
        app_aconst(YES);
        app_repl(@',');
        }

    app_repl(@'0'); // String terminator.
    app_repl(@'}');
    }
#endif
}

@ Append the translation of an |ASCII| constant.
@<Part 3@>=

SRTN app_aconst FCN((fmt_char,leading_zero))
    outer_char fmt_char C0("Either 'o' (octal) or 'd' (decimal)")@;
    boolean leading_zero C1("For octal format")@;
{
eight_bits n; // Value of the constant.
outer_char value[10],*v;

if (*id_first==@'@@')
    { /* The construction `\.{@@'@@@@'}'. */
    n = *id_first++; // Advance past first~`\.{@@}'.

    if (*id_first != @'@@') ERR_PRINT(T,"Should use double @@ within \
ASCII constant");
    else id_first++;
    }
else if (*id_first==@'\\')
    { /* Something like `\.{@@'\\040'}' or~`\.{@@'\\n'}', or it could
be an escaped delimiter. */
    id_first++; // Advance past the escape character.

    n = esc_achar((CONST ASCII HUGE * HUGE *)&id_first);

@#if 0
    switch (*id_first)
    {
    @<Convert escape char...@>@;
    default: err_print(T,"Invalid escape sequence '\\%c' \
in ASCII constant; null assumed",XCHR(*id_first));
        n = 0;
        break;
    }
@#endif
    }
else n = *id_first++; // ``Ordinary construction'' like `\.{@@'a'}'.

/* The following statement is for development while debugging the character
set translations.  From a normal \FTANGLE, \.{touch \{ftangle,common\}.web}
and run \.{make} with
``\.{DEBUGGING=-mscramble\_ASCII}''.  This adds some extra code to scramble
all the |ASCII| constants.  Then define |DEBUG_XCHR| in
\.{custom.h} and run \.{make} with ``\.{DEBUGGING=-a}''; this scrambles the
|ASCII| constants but also compiles using the new translation table.
Hopefully, it should work as before. */
#ifdef scramble_ASCII
    n = xxord[n];
#endif

#ifdef unscramble_ASCII
    n = XCHR(n);
#endif

/* Now |n|~has the numerical value of the |ASCII| constant; in octal, it's
something like~|0123|.  We now just append the octal representation as a
constant. */
  app_repl(constant);

  SPRINTF(10,value,`fmt_char=='o' ? "%s%o" : "%s%d",
    leading_zero ? "0" : "",n`);

  for(v=value; *v; v++)
    app_repl(XORD(*v));

  app_repl(constant);

#if(0) /* Kept around in case compiler can't understand \.{\%o}. */
int l;

if(leading_zero) app_repl(@'0'); // Beginning zero signifies octal constant.

  value[0] = @'0' + (n>>6); // Left-most digit.
  value[1] = @'0' + ((n-0100*(n>>6))>>3); // Center digit.
  value[2] = @'0' + (n-010*(n>>3)); // Right-most digit.

  for(l=0; l<3; l++)
    if(value[l] != @'0') break; // Kill off leading zeros for beauty.

  for( ; l<3; l++)
    app_repl(value[l]); // Nontrivial part.

#endif
}

@ Within macros, the \.{@'\dots'} constructions only works if the quote is
explicit, not if it's returned from another \WEB\ macro.  Therefore, we
introduce a built-in, to be used as `\.{\$A('\\321')}', which expands to its
argument if |translate_ASCII| is off or to `\.{0321}' if it's on.

@<Define internal macros@>=

SAVE_MACRO("_A(s)$$ASCII(s)");
SAVE_MACRO("$A(s)$$ASCII(s)");

SAVE_MACRO("_ASCII(s)$$ASCII(s)");
SAVE_MACRO("$ASCII(s)$$ASCII(s)");

@
@<Part 3@>=@[

SRTN i_ascii_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
int len; // Length to copy.
eight_bits *start = pargs[0] + 1; // Starting address of argument.

CHK_ARGS("$A",1);

if(translate_ASCII)
    {
    eight_bits HUGE *tok_ptr0 = tok_ptr; // Save starting position.

    if(*start == stringg) id_first = (ASCII HUGE *)(start + 1);
    else
        {
        err_print(T,"Argument of _A should be quoted; \
just returning argument");
        goto just_return;
        }

    cp_ASCII(); // Build result in the token area.

    len = tok_ptr - tok_ptr0;
    MCHECK(len,"_ascii_");
    memcpy(mp,tok_ptr0,len);
    tok_ptr = tok_ptr0; // Reset position.
    }
else
    { /* Just return the string argument. */
  just_return:
    len = pargs[1] - start;
    MCHECK(len,"_ascii_");
    STRNCPY(mp,start,len);
    }

mp += len;
}

@* SCANNING a MODULE.
The |scan_module| procedure starts when~`\.{@@\ }' or~`\.{@@*}' has been
sensed in the input, and it proceeds until the end of that module.  It
uses |module_count| to keep track of the current module number; with luck,
\.{WEAVE} and \.{TANGLE} will both assign the same numbers to modules.

@ The top level of |scan_module| is trivial.
@<Part 3@>=@[

SRTN scan_module(VOID)
{
name_pointer p = NULL; /* module name for the current module */

module_count++;

params = global_params;
frz_params();
set_output_file(global_language);

progress();

@<Scan the definition part of the current module@>; // \TeX, \.{@@d}, \.{@@f}.
@<Scan the code part of the current module@>; // Code.
}

@
@<Glob...@>=

EXTERN boolean is_WEB_macro SET(NO);
EXTERN boolean scanning_defn; // Deflects verbatim comments from def'n section.
EXTERN boolean scanning_TeX; /* To help out |scan_text| with the handling
                of vertical bars. */
EXTERN boolean nuweb_mode1; // In case \.{@@N} appears in defn section.

EXTERN int mlevel SET(0); // Level of preprocessor expansion.

@ Scan either to~\.{@@a} or~\.{@@<}. The one nuance here is that for the
very first module we must absorb the predefined macros, which are sitting
in the |macro_buf|.

@<Scan the definition part...@>=
{
parsing_mode = INNER;
nuweb_mode1 = nuweb_mode;

next_control=ignore;

if(module_count == 1)
    {
    *(mp-1) = @'@@';
    *mp = @'m';
    divert((ASCII HUGE *)macrobuf,(ASCII HUGE *)mp,STOP); /* Begin
        reading from
        the macro buffer, when some macros were predefined with
        |save_macro|. |mp-1| is positioned to the blank after the
        last definition. */
    }

/* Skip \TeX\ stuff and expand the definition section. */
scanning_TeX = YES;
 scan_text(macro,p,EXPAND);
scanning_TeX = NO;

if(module_count == 1) @<Has the |_BP| macro been defined?@>;

if(mlevel != 0)
    {
    err_print(M,"Invalid preprocessor block structure (level %d). \
Missing @@#endif?",mlevel);
    mlevel = 0;
    }
}

@ A global flag for checking preprocessor commands.

@<Glob...@>=

EXTERN boolean found_else SET(NO);

@ The actual work is done in this recursive function.  Preprocessor
segments are treated as independent units, processed separately with
|scan_repl|, then linked together.

@d MAX_LEVEL 20

/* We have to tell |scan_text| whether or not to expand the text it is
reading. */
@d EXPAND YES

@<Part 3@>=@[

SRTN scan_text FCN((text_type,p,expand))
    int text_type C0("Either |macro| or |module_name|.")@;
    CONST name_pointer p C0("Module name.")@;
    boolean expand C1("Do we expand?")@;
{
boolean if_switch;
boolean scanned_if = NO;
boolean first_text = YES;
eight_bits HUGE *pp;
text_pointer q;

scanning_defn = BOOLEAN(text_type==macro);

if(++mlevel >= MAX_LEVEL)
    FATAL("!! Conditional nesting depth exceeded",""); /* Increment and
remember the incoming processing level. */

WHILE()
    {
    if(scanning_defn && expand)
      {
      while(next_control<=ignore_defn)
        { // Skip \TeX\ stuff, \.{@@f}, \.{@@l}, \.{@@v}, and \.{@@W}.
         if((next_control=
            skip_ahead(next_control,YES))==module_name)
            { /* scan the module name too */
             loc-=2; next_control=get_next();
            }
        }
      scanning_TeX = NO;
       }
    else /* Process incoming code text. */
       if(!expand)
        {
        while( (next_control =
              skip_ahead(next_control,YES)) == module_name)
             if( (next_control=skip_ahead(next_control,YES)) != ignore)
                ERR_PRINT(T,"Expected @@> after @@<");
        }
       else
        { /* Process another complete fragment of code. */
        @<Insert the module number into |tok_mem|@>@;
        scan_repl(module_name,stop_the_scan); /* Now |cur_text|
points to the replacement text. */
        @<Update the data structure so that the replacement text is
accessible@>@;
        first_text = NO;
        }

   next_macro_token:
    switch(next_control)
        {
       @<Preprocessor cases@>@;

       case new_output_file:
        err_print(T,"@@O and @@o are allowed only in the code \
section; command ignored");
        next_control = ignore;
        loc = limit + 1;
        break;

       case definition: case undefinition:
       case WEB_definition:
        if(!expand)
            next_control = ignore;
        else
            {
            name_pointer np;
            eight_bits last_control;

            if((np=app_macro(last_control=next_control))
                 == NULL) continue;
            else if(last_control==WEB_definition)
                np->equiv = (EQUIV)cur_text;
            }
        break;


       default:
        if(next_control <= ignore_defn)
            break;

        mlevel--;
        return;
        }
    }
}

@ The following macro implements either |m_ifdef| or |m_ifndef|. The
argument |compares| should be `|!=|' for |m_ifdef| or `|==|' for |m_ifndef|.
@d DEF_OR_NDEF(flag)
    found_else = NO;
    if(!expand)
        {
        to_endif(m_ifdef);
        goto next_macro_token;
        }
    else
        {
        text_pointer m;
        if( (next_control=get_next()) != identifier)
            {
            ERR_PRINT(T,"Expected identifier after @@#ifdef \
or @@#ifndef; assuming not defined");
            if_switch = NO;
            }
        else if_switch =
          BOOLEAN(flag((m=MAC_LOOKUP(ID_NUM(id_first,id_loc)))!=NULL
            && !(m->built_in)));
    /* Is the identifier defined as a WEB macro? */
        if(if_switch)
            {
            GET_LINE; /* Skip possible comment at end of
\.{@@\#ifdef} or \.{@@\#ifndef}. */
            scan_text(text_type,p,if_switch);
            }
        else
            {
            expand=NO; @+ to_else();

            if(next_control != m_endif)
                {
                scanned_if = YES;
                goto next_macro_token;
                }
            else
                {
                next_control = ignore;
                expand = YES;
                GET_LINE; /* Skip possible comment after
\.{@@\#endif}. */
                break;
                }
            }
        }

/* The following were changed from |TRUE| and |FALSE| to avoid difficulties
with the VAX' \.{cc}.  */
@d M_TRUE
@d M_FALSE !

@<Preprocessor cases@>=

case m_ifdef:
    DEF_OR_NDEF(M_TRUE);
    break;

case m_ifndef:
    DEF_OR_NDEF(M_FALSE);
    break;

case m_if:
    found_else = NO;

    if(!expand)
        {
        to_endif(m_if);
        goto next_macro_token;
        }
    else
        @<Expand an |if| statement@>@;

    break;

case m_elif:
/* The |elif| is essentially the inverse of |if|. If we were in the midst
of an expansion, everything else must be skipped until |endif|. This is
done via |to_endif|; we must process the |endif| again in order to return
properly from the recursive scan in progress.  If we were not in the midst
of an expansion, we got here via a |to_else|; we must now proceed just as
though this were an |if|. */
    next_control = ignore;

    if( (mlevel==1 && !scanned_if) || found_else)
        {
        OUT_OF_ORDER("elif");
        break;
        }

    scanned_if = NO;

    if(expand)
        {
        to_endif(m_elif);
        goto next_macro_token;
        }
    else
        @<Expand an |if|...@>@;

    expand = YES;
    break;

case m_else:
/* When processing an |else|, we take action based on the opposite of the
|expand| flag currently in effect. If |expand == YES|, we must then skip
everything else until the |endif|. This is done with |to_end|; we must
process the |endif| again in order to return properly from the recursion in
progress when we got here.  If |expand == NO|, we got here via a |to_else|;
we must now expand everything until the |endif|. */
    next_control = ignore;

    if( (mlevel == 1 && !scanned_if) || found_else)
        {
        OUT_OF_ORDER("else");
        break;
        }

    found_else = YES;
    scanned_if = NO;

    expand = BOOLEAN(!expand);

    GET_LINE; // Skip possible comment after \.{@@\#else}.

    if(expand)
        scan_text(text_type,p,expand);
    else
        {
        to_endif(m_else);
        expand = YES;
        goto next_macro_token;
        }

    break;

case m_endif:
    next_control = ignore;

    if(mlevel == 1)
        {
        OUT_OF_ORDER("endif");
        break;
        }

    found_else = NO;
    GET_LINE; // Skip possible comment after \.{@@\#endif}.
    mlevel--;
    return; // Ends recursion on |scan_text|.

case m_undef:
    if(!expand)
        next_control = ignore;
    else
        {
        if( (next_control=get_next()) != identifier)
            ERR_PRINT(M,"Identifier must follow @@#undef");
        else
            {
            undef(ID_NUM(id_first,id_loc),COMPLAIN);
            GET_LINE; /* Skip possible comment at end of
\.{@@\#undef}. */
            }
        }
    break;

case m_for:
case m_endfor:
case m_pragma:
    if(!expand) next_control = ignore;
    else
        {
          ERR_PRINT(M,"Sorry, preprocessor command isn't implemented yet");
        }
    break;

@

@d GET_LINE@/
     if(!from_buffer)
        if(language!=TEX)
            get_line()@;

@<Expand an |if|...@>=
{
@<Evaluate conditional expression and set |if_switch|@>;
GET_LINE; // Skip possible comment at end of \.{@@\#if}.

if(if_switch)
    scan_text(text_type,p,if_switch);
else
    @<Skip to |else|, |elif|, or |endif|@>@;
}

@ We get here when an |if| evaluated to~0. We must skip everything until
the next |elif|, |else|, or~|endif|. If the |to_else| scan gets to an
|elif| or |else|, we  go back and evaluate that token again, thus
continuing the processing. However, if we get directly to an |endif|, this
was the case |if(0)|\dots|endif|. In this case |scan_text| wasn't called
recursively at all, so we mustn't return, but should |break| instead.

@<Skip to |else|...@>=
{
expand=NO; @+ to_else();

if(next_control != m_endif)
    {
    scanned_if = YES;
    goto next_macro_token;
    }
else
    {
    next_control = ignore;
    expand = YES;
    GET_LINE; // Skip possible comment after \.{@@\#endif}
    break;
    }
}

@ An error message for out-of-order preprocessor commands.

@d OUT_OF_ORDER(cmd) out_of_order((outer_char *)cmd)

@<Part 3@>=@[

SRTN out_of_order FCN((cmd))
    CONST outer_char cmd[] C1("Name of bad preprocessor command.")@;
{
err_print(M,"Ignored out-of-order \"@@#%s\" (mlevel = %d)",cmd,mlevel);
}

@ We get here when we're not supposed to expand the stuff after an
\&{@@\#elif}.  We must scan without expanding to the next \&{@@\#elif},
\&{@@\#else}, or \&{@@\#endif}, taking into account the possibility of
further nested \&{@@\#if}\dots\&{@@\#endif} combinations.

@<Part 3@>=@[

SRTN to_else(VOID)
{
int elevel = 0,elifs[MAX_LEVEL],elses[MAX_LEVEL],k;

for(k=0; k<MAX_LEVEL; k++)
    elifs[k] = elses[k] = 0;

WHILE()
    switch(next_control=skip_ahead(next_control,NO))
        {
        case m_if:
        case m_ifdef:
        case m_ifndef:
            elevel++;
            break;

        case m_elif:
            if(elses[elevel])
                   ERR_PRINT(M,"Can't have @@#elif after @@#else");
            elifs[elevel]++;
            if(elevel==0) return;
            break;

        case m_else:
            if(elses[elevel]++)
                ERR_PRINT(M,"Only one @@#else allowed \
(scanning to @@else)");
            if(elevel==0)
                {
                if(language==TEX && !get_line())
                    loc = limit + 1;
                return;
                }
            break;

        case m_endif:

            elifs[elevel] = elses[elevel] = 0;

            if(elevel-- == 0)
                {
                found_else = NO;
                if(language==TEX && !get_line())
                    loc = limit + 1;
                return;
                }
            break;

        case new_module:
            err_print(M,"Section ended during scan for \
\"@@#else\", \"@@#elif\", or \"@@#endif\". Inserted \"@@#endif\". \
(elevel = %d)",elevel);
            if(elevel == 0)
                found_else = NO;

            return;// The |new_module| is turned into an |m_endif|.
        }
}

@ The function is similar to |to_else|, but we're scanning to an \&{endif}.
@<Part 3@>=@[

SRTN to_endif FCN((m_case))
    int m_case C1("Case that called to_endif")@;
{
int elevel = 1,elifs[MAX_LEVEL],elses[MAX_LEVEL],k;

for(k=0; k<MAX_LEVEL; k++)
    elifs[k] = elses[k] = 0;

if(m_case==m_elif)
    elifs[elevel] = 1;
else
    {
    if(m_case==m_else)
        elses[elevel] = 1;
    }

WHILE()
    switch(next_control=skip_ahead(next_control,NO))
        {
        case m_if:
        case m_ifdef:
        case m_ifndef:
            elevel++;
            break;

        case m_elif:
            if(elses[elevel])
                   ERR_PRINT(M,"Can't have @@#elif after @@#else");
            elifs[elevel]++;
            break;

        case m_else:
            if(elses[elevel]++)
                ERR_PRINT(M,"Only one @@#else allowed \
(scanning to @@endif)");
            break;

        case m_endif:

            elifs[elevel] = elses[elevel] = 0;

            if(--elevel == 0)
                {
                found_else = NO;
                if(language==TEX && !get_line())
                    loc = limit + 1;
                return;
                }
            break;

        case new_module:
            err_print(M,"Section ended during scan for \
\"endif\"; inserted \"endif\". (elevel = %d)",elevel);
            if(elevel == 0)
                found_else = NO;
            return;
        }
}

@ This fragment evaluates the argument to an \.{@@\#if} or \.{@@\#elif}.
@<Evaluate conditional...@>=
{
boolean scan0 = scanning_defn;

scanning_defn = YES;
    scan_repl(macro,STOP);
scanning_defn = scan0;

cur_text->nargs = UNDEFINED_MACRO;

pp = xmac_text(macrobuf,cur_text->tok_start,tok_ptr); // See \.{macs.web}.
if_switch = eval(pp,mp); // See \.{eval.web}.
}

@ Handle a macro definition.  \WEB\ macro definitions may have the special
forms~\.{@@m*} or~\.{@@m[\dots]}.  The asterisk indicates a recursive macro
(not implemented yet).  The \.{[\dots]} construction signifies automatic
insertion material; see the next module for more details.

@<Part 3@>=@[

name_pointer app_macro FCN((last_control))
    eight_bits last_control C1("Last token processed.")@;
{
sixteen_bits a;
name_pointer np = NULL;
boolean make_recursive = NO;
ASCII insert_type[6];
int insert_num = 0;
eight_bits temp[2]; // Holds the macro identifier.
boolean nuweb_mode0 = nuweb_mode;

nuweb_mode = NO; // Don't parse the beginning of macro defn's literally.

is_WEB_macro = BOOLEAN(last_control==WEB_definition);

if(is_WEB_macro || C_LIKE(language))
    {
      while ((next_control=get_next())==@'\n')
        ; // Allow definition to start on  next line.

    if(is_WEB_macro)
        if(next_control == MAKE_RECURSIVE)
            {
            make_recursive = YES;
            next_control=get_next();
            }
        else if(next_control == AUTO_INSERT)
            @<Set up auto insertion@>@;

      if (next_control!= identifier)
        {
        err_print(M,"Definition flushed in %s; must start with \
identifier", MTRANS);
@.Definition flushed...@>
        np = NULL;
        goto done_append;
        }

    a = ID_NUM_ptr(np,id_first,id_loc); // The identifier.

/* Process auto insertion. */
    temp[0] = LEFT(a,ID0); @+ temp[1] = RIGHT(a);
    @<Store auto insertion@>@;

/* Append the lhs. */
    app_repl(temp[0]);
    app_repl(temp[1]);

    np->macro_type = IMMEDIATE_MACRO;
/* Mark this name as a macro. |macro_type| isn't otherwise used by \Tangle. */

      if (*loc!=@'(')
        {
        if(is_WEB_macro)
            {app_repl(@' ');}
            else if(C_LIKE(language))
            { /* For outer macros, identifier must be separated
from replacement text */
                app_repl(stringg); app_repl(@' '); app_repl(stringg);
            }
        }
    }

nuweb_mode = nuweb_mode0;
scan_repl((eight_bits)macro,(boolean)(!scanning_defn)); /* Copy stuff
            verbatim. (Also sets the language.) */

/* Finish off storing the macro. */
if(is_WEB_macro)
    @<Argize a \.{WEB} macro@>@;
else
    cur_text->nargs = (eight_bits)CHOICE(last_control==definition,
        OUTER_MACRO, OUTER_UNMACRO); // Mark the outer macros.

cur_text->text_link = macro; // |text_link=0| characterizes a macro.

done_append:
    is_WEB_macro = NO;    // Reset.
    return np;
}

@ \WEB\ macro definitions may begin with the construction \.{@@m[*]} or
\.{@@m[pmsfbi]}, indicating that in \Ratfor\ this macro is to be output
automatically after one or more of the program units |program|, |module|,
|subroutine|, |function|, |blockdata|, and |interface|.
@<Set up auto insert...@>=
{
ASCII c;

while((c= *loc++)!=END_AUTO_INSERT)
    {
    if(*loc == @' ')
        {
        ERR_PRINT(M,"Found space instead of ']' after automatic \
insertion material");
        break;
        }

    if(loc == limit) break;

    if(insert_num >= 6)
        {
        if(insert_num++ == 6)
           ERR_PRINT(M,"Can't have more than 6 types of automatic \
insertion material; remaining ignored");
        continue;
        }

    switch(c)
        {
       case @'*':
        STRNCPY(insert_type,"pmsfbi",insert_num=6);
        break;

       case @'p': case @'P':
       case @'m': case @'M':
       case @'s': case @'S':
       case @'f': case @'F':
       case @'b': case @'B':
       case @'i': case @'I':
        insert_type[insert_num++] = c;
        break;

       default:
        ERR_PRINT(M,"Auto insertion type must be one of \
\"ibfmps\"");
        continue;
        }
    }

next_control = get_next();
}

@ Here we save the macro identifier of automatic insertion material.

@m SAVE_AUTO(type) if(insert.type.end > insert.type.start)
    err_print(M,"Overriding previous auto insertion type %s",#type);
    STRNCPY(insert.type.start,temp,2);
    insert.type.end = insert.type.start + 2

@<Store auto insert...@>=
{
while(insert_num-- > 0)
    switch(insert_type[insert_num])
        {
       case @'p': case @'P':
        SAVE_AUTO(program);
        break;

       case @'m': case @'M':
        SAVE_AUTO(module);
        break;

       case @'s': case @'S':
        SAVE_AUTO(subroutine);
        break;

       case @'f': case @'F':
        SAVE_AUTO(function);
        break;

       case @'b': case @'B':
        SAVE_AUTO(blockdata);
        break;

       case @'i': case @'I':
        SAVE_AUTO(interface);
        break;
        }
}

@ Put argument tokens into the token list for a WEB macro, and also strip
off newlines.
@<Argize a...@>=
{
text_ptr->tok_start = tok_ptr = argize(cur_text->tok_start,tok_ptr); /* Set
    new end by possibly stripping off newlines. */
cur_text->Language = (boolean)global_language; // This value shouldn't matter.
cur_text->recursive = make_recursive;
}

@ Similarly, in order to implement the built-in command |$DEFINE|, we need
to store a macro definition that has already been fully tokenized.
@<Part 3@>=@[

SRTN app_dmacro FCN((p,p1))
    CONST eight_bits HUGE *p C0("Start")@;
    CONST eight_bits HUGE *p1 C1("End.")@;
{
eight_bits a0,a1;
sixteen_bits a;
name_pointer np;
boolean make_recursive = NO;

if(*p == MAKE_RECURSIVE)
    {
    make_recursive = YES;
    p++;
    }

if(p+2 > p1)
    {
    MACRO_ERR("Invalid argument to $DEFINE",YES);
    return;
    }

if(TOKEN1(a0 = *p++))
    {
    MACRO_ERR("$DEFINE flushed; must start with identifier",YES);
    return;
    }

a = IDENTIFIER(a0,a1 = *p++);
app_repl(a0);
app_repl(a1);

np = name_dir + a;

np->macro_type = IMMEDIATE_MACRO;

if(*p == @'=') {p++; app_repl(@' ');} // Allow for zero-argument macro.

while(p < p1) {app_repl(*p++);}

@<Make |cur_text...@>;
@<Argize a...@>;
cur_text->text_link = macro;
np->equiv = (EQUIV)cur_text;
}

@ In terms of |app_dmacro|, we can also implement a built-in |$DEFINE| command.
@<Define internal macros@>=

SAVE_MACRO("_DEFINE(defn)$$DEFINE(defn)");
SAVE_MACRO("$DEFINE(defn)$$DEFINE(defn)");

SAVE_MACRO("_M(defn)$$DEFINE(defn)"); /* Shorthand for above. */
SAVE_MACRO("$M(defn)$$DEFINE(defn)"); /* Shorthand for above. */

@ The internal |$DEFINE| function just appends a deferred macro.
@<Part 3@>=@[

SRTN i_define_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
CHK_ARGS("$M",1);

app_dmacro(pargs[0]+1,pargs[1]);
}

@ We also need an |$UNDEF| command.
@<Define internal macros@>=

SAVE_MACRO("_UNDEF(id)$$UNDEF(#!id)");
SAVE_MACRO("$UNDEF(id)$$UNDEF(#!id)");

@
@<Part 3@>=@[

SRTN i_undef_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
eight_bits a0;
eight_bits HUGE *p = pargs[0]+1;

CHK_ARGS("$UNDEF",1);

if(p+2 > pargs[1])
    {
    MACRO_ERR("Invalid argument to $UNDEF",YES);
    return;
    }

if(TOKEN1(a0 = *p++))
    {
    MACRO_ERR("$UNDEF flushed; must start with identifier",YES);
    return;
    }

undef(IDENTIFIER(a0,*p),COMPLAIN);
}

@ We can now build in some simple arithmetic macros.
@<Define internal macros@>=

SAVE_MACRO("_INCR(N,...)$INCR0(#!N,$EVAL(N+$IFELSE(#0,0,1,#1)))");
SAVE_MACRO("$INCR(N,...)$INCR0(#!N,$EVAL(N+$IFELSE(#0,0,1,#1)))");

SAVE_MACRO("_DECR(N,...)$INCR0(#!N,$EVAL(N-$IFELSE(#0,0,1,#1)))");
SAVE_MACRO("$DECR(N,...)$INCR0(#!N,$EVAL(N-$IFELSE(#0,0,1,#1)))");

SAVE_MACRO("_INCR0(N,N1)$$DEFINE(#!N N1)");
SAVE_MACRO("$INCR0(N,N1)$$DEFINE(#!N N1)");

@
@<Scan the code...@>=
switch (next_control)
    {
  case begin_code: /* \.{@@a} */
    {
    params = global_params; // The unnamed module has the global state.
    frz_params();
    set_output_file(global_language);

    p = name_dir;
    @<Start column mode.@>;
    break;
    }

  case module_name: /* \.{@@<} */
    if(cur_module)
        {
        p = cur_module;
        params = cur_module->mod_info->params; // Restore state.
        }
    else
        { // We get here if the module name was bad.
@#if 0
        ERR_PRINT(T,"Code placed into unnamed module");
        p = name_dir;
        params = global_params;
@#endif
/* The above wasn't a good idea.  It's better to flush the module. */
        while( (next_control=skip_ahead(ignore,NO)) != new_module);
        return;
        }

      @<Check that |=| or |==| follows this module name, otherwise |return|@>;
    frz_params();
    @<Start column mode.@>;
    break;

  default: return;
    }

nuweb_mode = nuweb_mode1;

/* Possibly turn on nuweb mode for output. */
app_repl(begin_language);
app_repl(NUWEB_OFF | nuweb_mode);
@<Make |cur_text = text_ptr|; update |text_ptr|@>;

next_control = ignore;
scan_text(module_name,p,EXPAND); // Expand the code section.
column_mode = NO;

/* Reset nuweb mode. */
app_repl(begin_language);
app_repl(NUWEB_OFF | global_params.Nuweb_mode);
@<Make |cur_text = text_ptr|; update |text_ptr|@>;

@
@<Check that |=|...@>=
{
while ((next_control=get_next()) == @'+'); // Allow optional `\.{+=}".

if (next_control != @'=' && next_control != eq_eq)
    {
    err_print(T,"Code text of %s flushed; = sign is missing", MTRANS);
@.Code text flushed...@>

    while ((next_control=skip_ahead(ignore,NO)) != new_module);

    return;
    }
}

@ When starting a Fortran code section, skip everything after the equals
sign so we start off fresh in the column mode.
@<Start column mode.@>=

if(FORTRAN_LIKE(language) && !free_form_input)
    @<Set up column mode@>@;

@ Prepare for \Fortran's idiotic syntax.
@<Set up col...@>=
{
loc = limit+1;
column_mode = YES;
parsing_mode = OUTER;
}

@
@<Insert the module number...@>=
{
store_two_bytes((sixteen_bits)(LINE_NUM+module_count));
}

@
@<Update the data...@>=
{
if(p==name_dir || p==NULL)
    { /* Unnamed module, or bad module name */
    cur_text->module_text = (first_text && mlevel==1);

/* The unnamed module begins in the global language.  However, subsequent
language changes within one section---e.g., by preprocessing---should be
retained. */
    if(cur_text->module_text)
        cur_text->Language = (boolean)global_language;

    last_unnamed->text_link = cur_text - text_info;
         // Link the unnamed module together.
    last_unnamed = cur_text; // Present end of the unnamed module.
    }
else if (p->equiv==(EQUIV)text_info)
    { /* First module of this name. */
    cur_text->module_text = YES;
    p->equiv = (EQUIV)cur_text;
    }
else
    { /* Link on the |cur_text| to the linked list. */
    LANGUAGE language0;

    q = (text_pointer)p->equiv; // Start of the chain.
    language0 = (LANGUAGE)q->Language; // Global language of this module.

/* Each replacement text (for a module name) has the same language as the
first in the chain.  Thus language switching works very efficiently;
modules inherit the language of their superior.  On the other hand,
preprocessor fragments should retain the current language, as should the
fragment following a preprocessor fragment. */
    cur_text->module_text = (first_text && mlevel==1);

    if(cur_text->module_text)
        cur_text->Language = (boolean)language0;

/* Find end of list, delimited by |module_flag|.  (There's nothing
comparable to |last_unnamed| to tell us where the end is.) */
    while (q->text_link < module_flag) q = q->text_link + text_info;

    q->text_link = cur_text - text_info;
        // Append more stuff to this module by linking in |cur_text|.
    }

/* |cur_text| has now been linked to the end of the appropriate chain.  Use
|module_flag| as a special |text_link| to signify the end of the list. */
cur_text->text_link = module_flag;
}

@ In phase~1, we skip the limbo section, set the global language, then
process each module in turn.
@<Part 3@>=@[

SRTN phase1(VOID)
{
LANGUAGE language0=language;

phase = 1;
module_count = 0;
rst_input(); rst_out(NOT_CONTINUATION);
reading(web_file_name,NO);

while ((next_control=skip_ahead(ignore,NO))!=new_module)
    ; // Skip stuff before first module.  This may reset the language.

chk_override(language0);
fin_language(); /* Make sure flags are initialized properly. */
global_params = params; /* Remember the global parameters. */
set_output_file(global_language); /* Language in force at the
                beginning of each module. */

while (!input_has_ended)
    scan_module(); // Do each module one at a time.

chk_complete(); // Anything left in change file?
@<Count the distinct modules@>@;
}

@ Here we set a global variable to the number of distinct modules. This is
used later in the expansion of the built-in macro |$MODULES|. The total
number of sections is also remembered, for use in the built-in |$SECTIONS|.
@<Glob...@>=

EXTERN sixteen_bits num_distinct_modules SET(1); // Count the unnamed module.
EXTERN sixteen_bits num_modules;

@
@<Count the distinct...@>=
@{
name_pointer np;

@b
for(np=name_dir; np<name_ptr; np++)
       if(np->equiv != NULL && np->equiv != (EQUIV)text_info
        && np->macro_type==NOT_DEFINED)
            num_distinct_modules++;

num_modules = module_count;
}

@ Here we  define a built-in macro that expands into the number of distinct
modules.
@<Define internal...@>=

SAVE_MACRO("_MODULES $$MODULES(0)");
SAVE_MACRO("$MODULES $$MODULES(0)");

SAVE_MACRO("_SECTIONS $$MODULES(1)");
SAVE_MACRO("$SECTIONS $$MODULES(1)");

@
@<Part 3@>=@[

SRTN i_modules_ FCN((n,pargs))
    int n C0("")@;
    PARGS pargs C1("")@;
{
outer_char temp[50];
int m=NSPRINTF(temp,"%c%u%c",XCHR(constant),
    *(pargs[0]+2) == '0' ? num_distinct_modules : num_modules,
    XCHR(constant));

CHK_ARGS("$MODULES",1);

MCHECK(m,"_modules_");
STRCPY(mp,to_ASCII(temp));
mp += m;
}

@ Print statistics at end of \FTANGLE's run.
@<Part 3@>=

SRTN see_tstatistics(VOID)
{
CLR_PRINTF(info,("\n\nMEMORY USAGE STATISTICS:\n"));
STAT0("names",sizeof(*name_ptr),
    SUB_PTRS(name_ptr,name_dir),max_names,UPPER(max_names),",");

STAT0("replacement texts",sizeof(*text_ptr),
    SUB_PTRS(text_ptr,text_info),max_texts,UPPER(max_texts),",");

STAT0("deferred texts",sizeof(*txt_dptr),
    SUB_PTRS(txt_dptr,txt_dinfo),dtexts_max,UPPER(dtexts_max),";");

STAT0("bytes",sizeof(*byte_ptr),
    SUB_PTRS(byte_ptr,byte_mem),max_bytes,UPPER(max_bytes),",");

STAT0("tokens",sizeof(*tok_ptr),
    SUB_PTRS((mx_tok_ptr > tok_ptr ? mx_tok_ptr : tok_ptr),tok_mem),
        max_toks,UPPER(max_toks_t),",");

STAT0("deferred tokens",sizeof(*tok_dptr),
    SUB_PTRS((mx_dtok_ptr > tok_dptr ? mx_dtok_ptr : tok_dptr),tok_dmem),
        max_dtoks,UPPER(max_dtoks),".");

mem_avail(1); /* How much memory left at end of run. */
}

@ This is an interface to |predefine_macros| in \.{macs.web}.
@<Part 3@>=@[

SRTN t_macros(VOID)
{
@<Define internal...@>;
}

@ Send a commented message to the output file.

In some cases, the message we want to send might involve fragments of
code that have to be translated. Therefore, we first use |str_to_mb| to
detokenize the message, then we ship it out in the form of a meta-comment.

@d SPCS_AFTER_CMNT 1 // For beautification of the Ratfor error messages.

@<Glob...@>=

#if SMALL_MEMORY
    #define MSG_BUF_SIZE 5000
#else
    #define MSG_BUF_SIZE 50000L
#endif

@
@<Part 3@>=@[

SRTN out_msg FCN((msg,msg1))
    CONST ASCII *msg C0("Start of message.")@;
    CONST ASCII *msg1 C1("See the description below.")@;
{
eight_bits HUGE *temp;
eight_bits HUGE *mp0 = mp,
    HUGE *macrobuf0 = macrobuf, HUGE *macrobuf_end0 = macrobuf_end;
char HUGE *new_msg; // The translated message.
boolean nuweb_mode0,in_string0,meta_mode0;

/* Translate the message, which may contain identifiers, into the |macrobuf|.*/
mp = macrobuf = temp = GET_MEM("out_msg:temp",MSG_BUF_SIZE,eight_bits);
macrobuf_end = temp + MSG_BUF_SIZE;

/* If |msg1 != NULL|, then it denotes the end of the array. If it is
|NULL|, we assume it's an ordinary character string and determine the end. */
if(msg1==NULL)
    msg1 = msg + STRLEN(msg);

new_msg = (char HUGE *)str_to_mb((eight_bits HUGE *)msg,
                (eight_bits HUGE *)msg1,NO);

/* Ship it out in the form of a meta-comment. */
spcs_after_cmnt = SPCS_AFTER_CMNT;

/* We bracket the output message by a standard set of |nuweb_mode|,
|meta_mode|, and |in_string| in order that the top, bottom, and prefix
fields work correctly. */
nuweb_mode0 = nuweb_mode;
in_string0 = in_string;
meta_mode0 = meta_mode;

meta_mode = nuweb_mode = NO;
@%in_string = YES;

OUT_CHAR(begin_meta);
OUT_CHAR(begin_meta); // Second one turns off |xpn_Ratfor|.
      while(*new_msg)
        OUT_CHAR(*new_msg++);
OUT_CHAR(end_meta);

nuweb_mode = nuweb_mode0;
in_string = in_string0;
meta_mode = meta_mode0;

spcs_after_cmnt = 0;

FREE_MEM(temp,"out_msg:temp",MSG_BUF_SIZE,eight_bits);
macrobuf = macrobuf0; @+ mp = mp0; @+ macrobuf_end = macrobuf_end0;
}

@
@<Part 3@>=

static sixteen_bits id_unroll;

SPEC univ_tokens[] = {
    {"_UNROLL",0,x_unroll,&id_unroll},
    {"$UNROLL",0,x_unroll,&id_unroll},
    {"",0,NULL,NULL}
    };

SRTN ini_univ_tokens FCN((language0))
    LANGUAGE language0 C1("")@;
{
ini_special_tokens(language0,univ_tokens);
}

@
@<Define internal macros@>=

SAVE_MACRO("_DO(k,kmin,kmax,...)$UNROLL(k,kmin,kmax,$IFCASE(#0,1,#.))");
SAVE_MACRO("$DO(k,kmin,kmax,...)$UNROLL(k,kmin,kmax,$IFCASE(#0,1,#.))");

@
@<Part 3@>=@[

SRTN ini_tokens FCN((language0))
    LANGUAGE language0 C1("")@;
{
switch(language0)
    {
   case C:
    break;

   case C_PLUS_PLUS:
    break;

   case FORTRAN:
    break;

   case FORTRAN_90:
    break;

   case TEX:
    break;

   default:
    break;
    }

ini_univ_tokens(language0);
}

@ Get the numerical value of a WEB |constant| string.
@<Part 3@>=@[

int get_constant FCN((e))
    eight_bits HUGE *e C1("")@;
{
boolean positive = YES;
int i = 1; // To prevent the increment from being~0 when an error occurs.

if(*e == @'-')
    {
    positive = NO;
    e++;
    }

if(*e++ != constant)
    {
    ERR_PRINT(T,"Invalid loop constant");
    return i;
    }

to_outer(e);
i = ATOI(e);
return (positive) ? i : -i;
}



@* STYLE FILE. The style file is common to \FWEAVE\ and \FTANGLE. See
\.{style.web}.

@<Include...@>=

#include "map.h" // Relations between style file keywords and internal arrays.

@* INDEX.  Here is a cross-reference table for the \.{TANGLE} processor.
All modules in which an identifier is used are listed with that identifier,
except that reserved words are indexed only when they appear in format
definitions, and the appearances of identifiers in module names are not
indexed. Underlined entries correspond to where the identifier was
declared. Error messages and a few other things like ``ASCII code'' are
indexed here too.